Alles Voor Internet / Tout Pour Internet

home *** CD-ROM | disk | FTP | other *** search

/ Alles Voor Internet / Tout Pour Internet / alles voor internet.iso / MacInternet™ / Archive-tools / binhex-vm-cms-files.txt < prev next >

Wrap

Internet Message Format | 1989-07-06 | 137KB

Date: Fri, 05 Jun 87 00:18:28 EDT From: Peter DiCamillo <CMSMAINT%BROWNVM.BITNET@forsythe.stanford.edu> Subject: BINHEX Command for CMS BINHEX is a command I've written for IBM VM/CMS systems to process BinHex (HQX) and MacBinary format files stored on CMS disks. BINHEX will check for CRC and other errors in the files, display the header information (Mac filename, creator, type, flags etc.), and convert files between the two formats. User documentation is contained in BINHEX HELPCMS; directions for creating BINHEX MODULE are in the main source file, BINHEX ASSEMBLE. Peter DiCamillo, Brown University Computer Center BITNET: CMSMAINT@BROWNVM Internet: CMSMAINT%BROWNVM@WISCVM.WISC.EDU --------------------------------------------------------------------- Contents: BINHEX ASSEMBLE 2453 lines Main program BINHEX HELPCMS 224 lines User documentation XMDMGEN C 62 lines Waterloo C pgm. to generate XMDMTAB XMDMTAB ASSEMBLE 46 lines Table for XMODEM CRC calculation Note: After uploading the ASSEMBLE files, they must be converted to fixed-length 80-byte records in order to be assembled. For example: COPYFILE BINHEX ASSEMBLE A = = = (LRECL 80 RECFM F ---------- start of BINHEX ASSEMBLE: 2453 lines follow -------------- BINHEX TITLE 'Program to Process BinHex and MacBinary Format Files' BINHEX CSECT SPACE *********************************************************************** * * * Name: * * BINHEX * * * * Author: * * Peter DiCamillo * * Brown University Computer Center * * Box 1885 * * Providence, RI 02912 * * (401) 863-2221 * * BITNET: CMSMAINT@BROWNVM * * ARPANET: CMSMAINT%BROWNVM@WISCVM.WISC.EDU * * * * Function: * * BINHEX checks, describes, and converts Macintosh files * * stored in CMS. It is able to work with both MacBinary for- * * mat (Macterminal, BinHex 5.0) and BinHex format (BinHex 4.0) * * files. * * * * Command format: * * BINHEX ?|Check|Describe|COnvert fn <ft <fm>> <( options <)>> * * See the HELP file for detailed information. * * * * Normal Exits: * * Returns to CMS with R15 = 0. For the ?, Check, and Describe * * operands, repsonses are generated before returning. * * * * Error Conditions: * * Returns to CMS with a non-zero return code after typing an * * error message. Errors messgae and return codes are listed in * * the HELP file. * * * * CMS System Calls: * * CMS nucleus routines called via BALR: * * ESTATE, ESTATEW, ADTLKP, RDBUF, WRBUF, FINIS * * CMS routines called via SVC 202 or 203: * * IDENTIFY, CONWAIT, TYPLIN, ATTN, EXECCOMM, DMSERR, LINEDIT * * * * External References: * * For CRC calculation, BINHEX uses a table defined in XMDMTAB * * ASSEMBLE. * * * * Attributes: * * BINHEX loads in the user program area. In order to call * * nucleus routines via BALR (for speed), it disables * * interrupts and runs with the system storage key. * * * *********************************************************************** EJECT *********************************************************************** * * * Module Generation: * * To create a new BINHEX MODULE, use the commands: * * GLOBAL TXTLIB DMSSP CMSLIB * * ASSEMBLE BINHEX * * ASSEMBLE XMDMTAB * * LOAD BINHEX * * GENMOD BINHEX * * * * Update History: * * June 1, 1987: Initial implementation, Peter DiCamillo * * * *********************************************************************** EJECT PRINT NOGEN REGEQU USING *,R15 STM R0,R15,REGSAVE Save all registers LR R11,R15 Use R11-R13 as base registers LA R12,2048(R11) LA R12,2048(R12) LA R13,2048(R12) LA R13,2048(R13) DROP R15 USING BINHEX,R11,R12,R13 USING NUCON,0 Address nucon L R10,AFVS R10 = FVSECT base register USING FVSECT,R10 DMSKEY NUCLEUS We need system key and no SSM =X'00' interruptions SR R15,R15 ST R15,RTNCODE Return code initialized to zero ST R15,CPS Initailize rate to zero MVI FLAGS,0 All flags = 0 MVI FLAGS2,0 MVI OPRCODE,C' ' First operand unknown MVC IFM(2),=CL2'*' Default input mode is "*" MVC OFM(2),=CL2'*' Default output mode is "*" L R2,=A(TOASCSTD) Set default EBCDIC to ASCII table ST R2,TOASCADR L R2,=A(FRASCSTD) Set default ASCII to EBCDIC table ST R2,FRASCADR BAL R14,GETID Get local node id CLC NODEID(8),BROWNID If Brown, use local tables BNE XTABOK L R2,=A(TOASCBRN) ST R2,TOASCADR L R2,=A(FRASCBRN) ST R2,FRASCADR XTABOK EQU * L R2,=A(WRITBUFF) R2 -> buffer L R3,=A(VALIDTAB) R3 -> TRT table MVI 0(R3),X'FF' Initialize VALIDTAB for TRTs MVC 1(255,R3),0(R3) L R4,=A(BINTOASC) R4 -> ASCII character list MVC 0(64,R2),0(R4) Copy valid ASCII characters L R4,FRASCADR R2 -> ASCII-to-EBCDIC table TR 0(64,R2),0(R4) Convert to valid EBCDIC characters LA R4,64 R4 = count for BCT SR R5,R5 R5 = 0 for IC VINITLP EQU * Loop to fill-in VALIDTAB IC R5,0(R2) Get new character in R5 LA R6,0(R3,R5) R6 -> position in table MVI 0(R6),0 Store zero there LA R2,1(R2) R2 -> next character BCT R4,VINITLP Repeat for all 64 character B OPERCHK Skip over save area SPACE REGSAVE DS 8D Register save area RTNCODE EQU REGSAVE+60 Return code at location for R15 EJECT * Check for valid first operand (function) OPERCHK LA R1,8(R1) R1 -> operand CLI 0(R1),X'FF' Operand there at all? BE BADFMT No, give error message LA R3,8 Get operand length in R3 LA R2,7(R1) R2 -> last byte OPRLENLP EQU * Loop to get length CLI 0(R2),C' ' At non-blank? BNE HAVEOPRL Yes, length in R3 BCTR R2,0 R2 -> previous byte BCT R3,OPRLENLP Decrement and repeat B BADFMT All blank is error SPACE HAVEOPRL BCTR R3,0 Decrement length for EX LA R2,OPRTAB R2 -> operand table OPRTBCHK EQU * Look for match in table CLI 0(R2),X'FF' At table end? BE BADFMT Yes, format error EX R3,OPRCLC Found a match? BE USEOPR Yes, handle operand LA R2,12(R2) R2 -> next operand B OPRTBCHK Try again SPACE OPRCLC CLC 0(*-*,R2),0(R1) Compare table entry to operand SPACE USEOPR L R2,8(R2) R2 -> operand code BR R2 Execute code for operand SPACE CHKOPR MVI OPRCODE,C'C' Set code C for CHECK B READID SPACE CVTOPR MVI OPRCODE,C'V' Set code V for CONVERT B READID SPACE DESCOPR MVI OPRCODE,C'D' Set code D for DESCRIBE B READID SPACE QUESOPR EQU * For ?, type command format WRTERM 'Format is: BINHEX ?|Check|Describe|COnvert fn ft <fm> X <( options <)>>' WRTERM ' Options: <To fm> <Rate cps> <Stack> <Lifo> <Fifo> <SX TEm stemname>' B CMSRTN Return right away SPACE * After function operand, get file id READID LA R1,8(R1) R1 -> possible FN CLI 0(R1),X'FF' Error if missing or "*" BE BADFMT CLI 0(R1),C'*' BE BADFMT MVC IFN(8),0(R1) Copy FN MVC IFT(8),=CL8'*' Set default filetype LA R1,8(R1) R1 -> possible FT CLI 0(R1),X'FF' Done if no FT, FM or options BE OPTDONE CLI 0(R1),C'(' If '(', start options BE OPTSCAN MVC IFT(8),0(R1) Copy FT LA R1,8(R1) R1 -> past FT CLI 0(R1),X'FF' Done if no FM or options BE OPTDONE CLI 0(R1),C'(' If '(', start options BE OPTSCAN CLI 2(R1),C' ' 3rd character of FM must be blank BNE BADFMT CLC 0(2,R1),=CL2'*' Skip copy if default specified BE IFMDONE MVC IFM(2),0(R1) Copy filemode for input CLI IFM+1,C' ' If no mode number, use '1' BNE IFMDONE MVI IFM+1,C'1' IFMDONE LA R1,8(R1) R1 -> next argument CLI 0(R1),X'FF' Done if no options BE OPTDONE CLI 0(R1),C'(' If '(', start options BE OPTSCAN * Else command format error BADFMT LR R2,R1 R2 = scan pointer S R2,=F'8' Point to previous token DMSERR NUM=1,LET=E,SUB=(CHARA,(R2)), X TEXT='Error in command after ''........''' DMSERR NUM=2,LET=I, X TEXT='Issue BINHEX ? or HELP CMS BINHEX for more informaX tion' MVI RTNCODE+3,24 Set return code B CMSRTN Return to CMS SPACE * Process options OPTSCAN EQU * R1 -> '(' NEWOPT LA R1,8(R1) R1 -> possible option CLI 0(R1),X'FF' Option there? BE OPTDONE No, done scanning CLI 0(R1),C')' Also done if ')' BE OPTDONE LA R3,8 Get option length in R3 LA R2,7(R1) R2 -> last byte OPTLENLP EQU * Loop to get length CLI 0(R2),C' ' At non-blank? BNE HAVEOPTL Yes, length in R3 BCTR R2,0 R2 -> previous byte BCT R3,OPTLENLP Decrement and repeat B BADOPT All blank is error SPACE HAVEOPTL BCTR R3,0 Decrement length for EX LA R2,OPTTAB R2 -> option table OPTTBCHK EQU * Look for match in table CLI 0(R2),X'FF' At table end? BE BADOPT Yes, format error EX R3,OPTCLC Found a match? BE USEOPT Yes, handle option LA R2,12(R2) R2 -> next option B OPTTBCHK Try again SPACE OPTCLC CLC 0(*-*,R2),0(R1) Compare table entry to option SPACE USEOPT L R2,8(R2) R2 -> option code BR R2 Execute code for option SPACE TOOPT EQU * TO option LA R1,8(R1) R1 -> filemode CLI 0(R1),X'FF' Error if mode missing BE BADMODE CLI 2(R1),C' ' Error if more than 2 characters BNE BADMODE MVC OFM(2),0(R1) Copy output filemode B NEWOPT SPACE STEMOPT EQU * STEM option LA R1,8(R1) R1 -> stem name CLI 0(R1),X'FF' Error if stem missing BE BADSTEM MVC STEMNAME(8),0(R1) Save stem name OI FLAGS2,EXECVAR Remember stem given LA R3,8 Get stem length in R3 LA R2,7(R1) R2 -> last byte STMLENLP EQU * Loop to get length CLI 0(R2),C' ' At non-blank? BNE HAVESTML Yes, length in R3 BCTR R2,0 R2 -> previous byte BCT R3,STMLENLP Decrement and repeat B BADSTEM Error if all blank SPACE HAVESTML ST R3,STEMSIZE Save length of stem name B NEWOPT SPACE BADMODE LR R2,R1 R2 -> bad filemode DMSERR NUM=48,LET=E,TEXT='Invalid mode ''........''', X SUB=(CHARA,(R2)) MVI RTNCODE+3,24 Set return code B CMSRTN Return to CMS SPACE BADSTEM DMSERR NUM=637,LET=E,TEXT='Missing value for the ''STEM'' optiX on' MVI RTNCODE+3,24 Set return code B CMSRTN Return to CMS SPACE RATEOPT EQU * RATE option LA R1,8(R1) R1 -> rate CLI 0(R1),X'FF' Error if rate missing BE BADRATE BAL R14,DECCVT Convert to decimal in R2 BNP BADRATE Error if result not positive ST R2,CPS Store rate B NEWOPT Ready for next option SPACE BADRATE LR R2,R1 R2 -> bad rate DMSERR NUM=10,LET=E,TEXT='Invalid rate ''........''', X SUB=(CHARA,(R2)) MVI RTNCODE+3,24 Set return code B CMSRTN Return to CMS SPACE STKOPT EQU * STACK or FIFO option OI FLAGS,STKDESC Set flag to stack description B NEWOPT SPACE LIFOOPT EQU * LIFO option OI FLAGS,STKDESC+STKLIFO Set stack and FIFO flags B NEWOPT SPACE BADOPT LR R2,R1 R2 -> bad option DMSERR NUM=3,LET=E,TEXT='Invalid option ''........''', X SUB=(CHARA,(R2)) MVI RTNCODE+3,24 Set return code B CMSRTN Return to CMS SPACE OPTDONE EQU * Done scanning plist * Check input file, get actual filemode, and check for BIN file LA R1,INPLIST Call STATE for input file L R15,AESTATE BALR R14,R15 BNZ STATERR Check for any errors CLC IFT(8),=CL8'*' * or no filetype specified? BNE FTOK No, keep filetype MVC IFT(8),FVST Else copy from file we found FTOK CLC FVSIL(4),=F'256' Return error if lrecl too big BH LRECLERR L R2,FVSFSTAD R2 -> ADT for input file disk USING ADTSECT,R2 IC R1,ADTM Fill-in actual disk letter and STC R1,IFM mode number for file which IC R1,FVSM+1 was found STC R1,IFM+1 DROP R2 CLI OFM,C'*' If OFM not filled-in, use input BNE MDNUMTST file disk letter IC R1,IFM STC R1,OFM MDNUMTST CLI OFM+1,C' ' If OFM not filled-in, use input BNE BINCHK file mode number IC R1,IFM+1 STC R1,OFM+1 BINCHK EQU * Check for MacBinary input file CLI FVSFV,C'F' Is recfm F? BNE NOTBIN No, not MacBinary CLC FVSIL(4),=F'128' Is lrecl 128? BNE NOTBIN No, not MacBinary OI FLAGS,MACBIN Else set flag for MacBinary NOTBIN EQU * * Define input file RDBUF plist LA R0,1 R0 = 1 for initializing SR R15,R15 R15 = 0 for initializing MVC INCMMD(8),=CL8'RDBUF' Command name STH R15,RDUN1 Unused halfword L R1,=A(READBUFF) Buffer address ST R1,RDADDR MVC RDBUFLTH(4),=F'256' Buffer size MVI RDFV,C'V' Record format (works for F too) MVI RDFLAG,X'20' Plist flag STH R15,RDUN2 Unused halfword ST R15,RDLGTH Bytes read ST R15,RDITEM Item number ST R0,RDITEC Item count ST R15,RDWP Write and read pointers ST R15,RDRP * If CONVERT specified, check output file status CLI OPRCODE,C'V' Convert specified? BNE INITDONE No, ready to start processing MVC OFN(8),IFN Output filename same as input MVC OFT(8),=CL8'BIN' Assume BIN for filetype TM FLAGS,MACBIN Is input MACBIN? BZ KEEPOFT No, BIN is correct MVC OFT(8),=CL8'HQX' Else use HQX KEEPOFT EQU * OFM already defined LA R1,OUTPLIST Call STATEW for output file L R15,AESTATEW BALR R14,R15 C R15,=F'28' Error if "File not found" BNE EXIERR not returned LA R1,OUTPLIST Get ADT for output disk L R15,VCADTLKP BALR R14,R15 BNZ ROERR (should not happen due to STATE) LR R2,R1 Check disk is R/W USING ADTSECT,R2 TM ADTFLG1,ADTFRW Is disk R/W? BZ ROERR No, give error DROP R2 * Define output file WRBUF plist LA R0,1 R0 = 1 for initializing SR R15,R15 R15 = 0 for initializing MVC OUTCMMD(8),=CL8'WRBUF' Command name STH R15,WRUN1 Unused halfword L R1,=A(WRITBUFF) Buffer address ST R1,WRADDR ST R15,WRBUFLTH Buffer size (will be set) MVI WRFV,C'V' Record format TM FLAGS,MACBIN MacBinary input file BO KEEPVAR Yes, keep recfm V MVC WRBUFLTH(4),=F'128' Lrecl 128 and recfm F for MVI WRFV,C'F' MacBinary output KEEPVAR MVI WRFLAG,X'20' Plist flag STH R15,WRUN2 Unused halfword ST R15,WRUN3 Unused word ST R15,WRITEM Item number ST R0,WRITEC Item count ST R15,WRWP Write and read pointers ST R15,WRRP INITDONE EQU * Ready to process files XC HDREC(128),HDREC Initialize header info. XC CHRTOTAL(4),CHRTOTAL Initialize count of characters TM FLAGS,MACBIN Separate processing for MacBinary BO BINPROC file format * * Read BinHex file to define file header info * LA R1,CVCNT0 Reset left over bit ST R1,BINXTADR processing MVI CMPCNT,0 Reset compression count XC BINLEN(4),BINLEN Reset count for BINBUFF XC CRCVAL(2),CRCVAL Reset CRC LA R0,1 R0 = length LA R1,HDFNLEN R1 -> buffer BAL R14,GETSTR Get length of filename BAL R14,CRCCALC Include in CRC SR R1,R1 Get length in R1 IC R1,HDFNLEN LTR R1,R1 Skip getting name if zero BZ NONAME C R1,=F'63' If >63, use 63 BNH FNLENOK L R1,=F'63' FNLENOK LR R0,R1 R0 = length LA R1,HDFN R1 -> buffer BAL R14,GETSTR Get filename BAL R14,CRCCALC Include in CRC NONAME LA R0,1 R0 = length LA R1,HDVER R1 -> buffer BAL R14,GETSTR Get version byte BAL R14,CRCCALC Include in CRC LA R0,10 R0 = length LA R1,HDFTYP R1 -> buffer BAL R14,GETSTR Get type, creator, flag bytes BAL R14,CRCCALC Include in CRC LA R0,8 R0 = length LA R1,HDDATALN R1 -> buffer BAL R14,GETSTR Get lengths of forks BAL R14,CRCCALC Include in CRC LA R0,2 R0 = length L R1,=A(DATABUFF) R1 -> buffer BAL R14,GETSTR Get header CRC BAL R14,CRCCALC Include in CRC CLC CRCVAL(2),=H'0' Is final CRC 0? BE HDCHKOK Yes, continue DMSERR LET=E,NUM=7,TEXT='''....................'': CRC error fX or BinHex header',SUB=(CHAR8A,IFN) MVI RTNCODE+3,44 Set RC = 44 B CMSRTN Return to caller SPACE HDCHKOK EQU * HQX header successfully read CLI OPRCODE,C'V' Conversion wanted? BNE HDDESC No, check for description LA R1,HDREC Output header record BAL R14,WR128 B CHKDATA Ready for data fork SPACE HDDESC CLI OPRCODE,C'D' Description wanted? BNE CHKDATA No, ready for data fork TM FLAGS2,EXECVAR Header info. wanted in vars.? BO HDVAR1 BAL R14,TYPEHDR Type header description B CHKDATA Ready for data fork SPACE HDVAR1 BAL R14,VARHDR Return info. in vars. CHKDATA EQU * Check data fork ICM R3,B'1111',HDDATALN Get data fork length LR R4,R3 R4 = number of 128-byte pieces SRL R4,7 LR R5,R4 R5 = bytes for all pieces SLL R5,7 SR R3,R5 R3 = bytes left over LA R0,128 R0 = byte count L R1,=A(DATABUFF) R1 -> buffer XC CRCVAL(2),CRCVAL Reset CRC LTR R4,R4 Any pieces to read? BNP DCHKLEFT No, skip loop DCHKLP EQU * Loop to read 128-byte pieces BAL R14,GETSTR Read 128 bytes BAL R14,CRCCALC Include in CRC CLI OPRCODE,C'V' Conversion wanted? BNE DCHKNXT No, continue BAL R14,WR128 Write data block DCHKNXT BCT R4,DCHKLP Repeat for all pieces DCHKLEFT LTR R3,R3 Any bytes left? BNP DCHKEND No, compare CRC XC 0(128,R1),0(R1) Initialize buffer LR R0,R3 Length = bytes left BAL R14,GETSTR Read bytes BAL R14,CRCCALC Include in CRC CLI OPRCODE,C'V' Conversion wanted? BNE DCHKEND No, continue BAL R14,WR128 Write data block DCHKEND LA R0,2 Get CRC BAL R14,GETSTR BAL R14,CRCCALC Include CRC CLC CRCVAL(2),=H'0' Is result zero? BE CHKRSC Yes, check resource fork DMSERR LET=E,NUM=8,TEXT='''....................'': CRC error fX or BinHex data fork',SUB=(CHAR8A,IFN) MVI RTNCODE+3,44 Set RC = 44 B CMSRTN Return to caller SPACE CHKRSC EQU * Check resource fork ICM R3,B'1111',HDRSCLN Get resource fork length LR R4,R3 R4 = number of 128-byte pieces SRL R4,7 LR R5,R4 R5 = bytes for all pieces SLL R5,7 SR R3,R5 R3 = bytes left over LA R0,128 R0 = byte count L R1,=A(DATABUFF) R1 -> buffer XC CRCVAL(2),CRCVAL Reset CRC LTR R4,R4 Any pieces to read? BNP RCHKLEFT No, skip loop RCHKLP EQU * Loop to read 128-byte pieces BAL R14,GETSTR Read 128 bytes BAL R14,CRCCALC Include in CRC CLI OPRCODE,C'V' Conversion wanted? BNE RCHKNXT No, continue BAL R14,WR128 Write data block RCHKNXT BCT R4,RCHKLP Repeat for all pieces RCHKLEFT LTR R3,R3 Any bytes left? BNP RCHKEND No, compare CRC XC 0(128,R1),0(R1) Initialize buffer LR R0,R3 Length = bytes left BAL R14,GETSTR Read bytes BAL R14,CRCCALC Include in CRC CLI OPRCODE,C'V' Conversion wanted? BNE RCHKEND No, continue BAL R14,WR128 Write data block RCHKEND LA R0,2 Get CRC BAL R14,GETSTR BAL R14,CRCCALC Include CRC CLC CRCVAL(2),=H'0' Is result 0? BNE RCHKERR No, give error RSCDONE EQU * BinHex code continues here CLI OPRCODE,C'D' Describe specified? BE DESCEND Yes, finish description CLI OPRCODE,C'C' Check specified? BNE CMSRTN No, ready to return CLI REGSAVE+4,X'0B' Called from command line? BNE CMSRTN No, ready to return L R8,=A(DATABUFF) R8 -> work buffer LINEDIT TEXT='''....................'': No errors detected', X SUB=(CHAR8A,IFN),BUFFA=(R8),DISP=NONE,RENT=NO BAL R14,TYPEDESC Type or stack line B CMSRTN SPACE DESCEND EQU * End file description L R8,=A(DATABUFF) R8 -> work buffer L R0,CHRTOTAL R0 = character count TM FLAGS2,EXECVAR Data in EXEC variables? BZ ENDTEXT No, do text L R1,=A(AVAR13) R1 -> CHARCNT string data LR R2,R1 Save R1 across NUMTOSTR LA R1,1(R8) R1 -> buffer for number BAL R14,NUMTOSTR Convert to string STC R0,0(R8) Store string length LR R1,R2 Restore R1 for SETVAR BAL R14,SETVAR Define stem.RESCSIZE L R4,CPS Was rate specified? LTR R4,R4 (Check if non-zero) BZ CMSRTN No, ready to return SR R5,R5 R5 = message length LA R6,1(R8) R6 -> next byte B TIMEMSG Join code for time estimate SPACE ENDTEXT MVC 1(17,R8),=C'Character count: ' Copy start of message LA R5,17 R5 = message length LA R6,1(R5,R8) R6 -> next byte LR R1,R6 R1 -> buffer BAL R14,NUMTOSTR Store number in string form AR R5,R0 Update length and address AR R6,R0 MVI 0(R6),C'.' Append period LA R5,1(R5) Update length and address LA R6,1(R6) STC R5,0(R8) Store length for TYPEDESC L R4,CPS Was rate specified? LTR R4,R4 (Check if non-zero) BZ RATEMSG No, ready to type message BCTR R6,0 R6 -> ending period MVC 0(2,R6),=C' (' Replace by blank, paren LA R5,1(R5) Adjust length for blank, paren LA R6,2(R6) R6 -> next byte TIMEMSG SR R2,R2 R2, R3 = character count L R3,CHRTOTAL DR R2,R4 Divide to get seconds in R3 SRL R4,1 R4 = half of divisor CR R2,R4 Remainder more than half? BNH KEEPSEC No, keep seconds A R3,=F'1' Else add one second KEEPSEC SR R2,R2 R2, R3 = seconds D R2,=F'60' R2 = secs., R3 = mins. LR R4,R2 Save seconds in R4 SR R2,R2 R2, R3 = minutes D R2,=F'60' R2 = minutes, R3 = hours LTR R0,R3 Any hours? BZ INCMIN No, ready for minutes LR R1,R6 R1 -> buffer BAL R14,NUMTOSTR Store string there AR R5,R0 Adjust length and address AR R6,R0 C R3,=F'1' Just one hour? BE ONEHOUR Yes, special case MVC 0(8,R6),=C' hours, ' Append text LA R5,8(R5) Adjust length and address LA R6,8(R6) B INCMIN Ready for minutes SPACE ONEHOUR MVC 0(7,R6),=C' hour, ' Append text LA R5,7(R5) Adjust length and address LA R6,7(R6) INCMIN LTR R0,R2 Any minutes? BZ INCSEC No, ready for seconds LR R1,R6 R1 -> buffer BAL R14,NUMTOSTR Store string there AR R5,R0 Adjust length and address AR R6,R0 C R2,=F'1' Just one minute? BE ONEMIN Yes, special case MVC 0(10,R6),=C' minutes, ' Append text LA R5,10(R5) Adjust length and address LA R6,10(R6) B INCSEC Ready for minutes SPACE ONEMIN MVC 0(9,R6),=C' minute, ' Append text LA R5,9(R5) Adjust length and address LA R6,9(R6) INCSEC LR R0,R4 R0 = number to convert LR R1,R6 R1 -> buffer BAL R14,NUMTOSTR Store string there AR R5,R0 Adjust length and address AR R6,R0 C R4,=F'1' Just one second? BE ONESEC Yes, special case MVC 0(12,R6),=C' seconds at ' Append text LA R5,12(R5) Adjust length and address LA R6,12(R6) B ENDTIME Ready to use text SPACE ONESEC MVC 0(11,R6),=C' second at ' Append text LA R5,11(R5) Adjust length and address LA R6,11(R6) ENDTIME L R0,CPS R0 = number to convert LR R1,R6 R1 -> buffer BAL R14,NUMTOSTR Store string there AR R5,R0 Adjust length and address AR R6,R0 TM FLAGS2,EXECVAR Is this for EXEC data BO TIMEVAR Yes, end differently MVC 0(6,R6),=C' cps).' Append text LA R5,6(R5) Update length STC R5,0(R8) Store new length for TYPEDESC RATEMSG BAL R14,TYPEDESC Type or stack line B CMSRTN SPACE TIMEVAR MVC 0(4,R6),=C' cps' Append text LA R5,4(R5) Update length STC R5,0(R8) Store new length for TYPEDESC L R1,=A(AVAR14) R1 -> TIMEEST string data BAL R14,SETVAR Define stem.TIMEEST B CMSRTN Ready to return SPACE RCHKERR DMSERR LET=E,NUM=9,TEXT='''....................'': CRC error fX or BinHex resource fork',SUB=(CHAR8A,IFN) MVI RTNCODE+3,44 Set RC = 44 B CMSRTN Return to caller SPACE BINPROC EQU * Process MacBinary file BAL R14,GETLINE Read 128-byte header record LTR R15,R15 Check for EOF (strange) BNZ GSEOF Use error code in GETSTR L R2,=A(READBUFF) R2 -> I/O buffer MVC HDREC(128),0(R2) Copy data to header area CLI OPRCODE,C'V' Conversion wanted? BNE BINHDESC No, check for description * Initialize for HQX output: L R1,=A(HQXMSG) R1 -> initial message line L R2,=A(WRITBUFF) R2 -> output buffer MVC 0(HQXMSGL,R2),0(R1) Copy message to buffer LA R1,HQXMSGL Get message length ST R1,WRLEN Store as line length BAL R14,HQXLINE Output line to file MVI 0(R2),C' ' Output one blank LA R1,1 Length = 1 ST R1,WRLEN BAL R14,HQXLINE Write blank line MVI 0(R2),C':' Initialize buffer with colon ST R1,WRLEN XC EXPLEN(4),EXPLEN Zero length for EXPBUFF MVI CMPMODE,0 Initial compression mode * Output HQX header data: XC CRCVAL(2),CRCVAL Reset CRC SR R2,R2 Get length of filename IC R2,HDFNLEN LA R0,1(R2) R0 = length with length byte LA R1,HDFNLEN R1 -> length BAL R14,HQXPUT Output to HQX file BAL R14,CRCCALC Include in CRC LA R0,1 R0 = 1 for version byte LA R1,HDVER R1 -> version byte BAL R14,HQXPUT Output version byte BAL R14,CRCCALC Include in CRC ICM R2,B'0011',HDFLAGS Save flag bits NC HDFLAGS(2),=X'F800' For HQX, 'and' with X'F800' LA R0,10 R0 = 10 (4+4+2) LA R1,HDFTYP R1 -> type BAL R14,HQXPUT Output type, creator, flags BAL R14,CRCCALC Include in CRC STCM R2,B'0011',HDFLAGS Restore original flag bits LA R0,8 R0 = 8 (4+4) LA R1,HDDATALN R1 -> lengths BAL R14,HQXPUT Output data and resource lengths BAL R14,CRCCALC Include in CRC LA R0,2 Include X'0000' in CRC LA R1,=H'0' BAL R14,CRCCALC LA R0,2 R0 = length of CRC LA R1,CRCVAL R1 -> CRC BAL R14,HQXPUT End header with CRC B BINDATA Ready for data fork SPACE BINHDESC CLI OPRCODE,C'D' Description wanted? BNE BINDATA No, ready for data fork TM FLAGS2,EXECVAR Header info. wanted in vars.? BO HDVAR2 BAL R14,TYPEHDR Type header description B BINDATA Ready for data fork SPACE HDVAR2 BAL R14,VARHDR Return info. in vars. BINDATA EQU * Process BinHex data fork ICM R3,B'1111',HDDATALN Get data fork length LR R4,R3 R4 = number of 128-byte records SRL R4,7 LR R5,R4 R5 = bytes for all records SLL R5,7 SR R3,R5 R3 = bytes left over LA R0,128 R0 = byte count L R1,=A(READBUFF) R1 -> buffer XC CRCVAL(2),CRCVAL Reset CRC LTR R4,R4 Any entire records to read? BNP BINDLEFT No, skip loop BINDLP EQU * Loop to read 128-byte records BAL R14,GETLINE Read 128-byte record LTR R15,R15 Check for EOF BNZ GSEOF Use error code in GETSTR CLI OPRCODE,C'V' Conversion wanted? BNE BINDNXT No, continue BAL R14,HQXPUT Write data block BAL R14,CRCCALC Include in CRC BINDNXT BCT R4,BINDLP Repeat for all pieces BINDLEFT LTR R3,R3 Any bytes left? BNP BINDEND No, check for writing CRC BAL R14,GETLINE Read 128-byte record LTR R15,R15 Check for EOF BNZ GSEOF Use error code in GETSTR CLI OPRCODE,C'V' Conversion wanted? BNE BINDEND No, skip writing data LR R0,R3 Use remaining bytes length BAL R14,HQXPUT Write data block BAL R14,CRCCALC Include in CRC BINDEND CLI OPRCODE,C'V' Conversion wanted? BNE BINRSC No, ready for resource fork LA R0,2 Include X'0000' in CRC LA R1,=H'0' BAL R14,CRCCALC LA R0,2 R0 = size of CRC LA R1,CRCVAL R1 -> CRC BAL R14,HQXPUT Output data fork CRC BINRSC EQU * Process BinHex resource fork ICM R3,B'1111',HDRSCLN Get resource fork length LR R4,R3 R4 = number of 128-byte records SRL R4,7 LR R5,R4 R5 = bytes for all records SLL R5,7 SR R3,R5 R3 = bytes left over LA R0,128 R0 = byte count L R1,=A(READBUFF) R1 -> buffer XC CRCVAL(2),CRCVAL Reset CRC LTR R4,R4 Any entire records to read? BNP BINRLEFT No, skip loop BINRLP EQU * Loop to read 128-byte records BAL R14,GETLINE Read 128-byte record LTR R15,R15 Check for EOF BNZ GSEOF Use error code in GETSTR CLI OPRCODE,C'V' Conversion wanted? BNE BINRNXT No, continue BAL R14,HQXPUT Write resource block BAL R14,CRCCALC Include in CRC BINRNXT BCT R4,BINRLP Repeat for all pieces BINRLEFT LTR R3,R3 Any bytes left? BNP BINREND No, check for writing CRC BAL R14,GETLINE Read 128-byte record LTR R15,R15 Check for EOF BNZ GSEOF Use error code in GETSTR CLI OPRCODE,C'V' Conversion wanted? BNE BINREND No, skip writing data LR R0,R3 Use remaining bytes length BAL R14,HQXPUT Write resource block BAL R14,CRCCALC Include in CRC BINREND CLI OPRCODE,C'V' Conversion wanted? BNE RSCDONE No, join common end code LA R0,2 Include X'0000' in CRC LA R1,=H'0' BAL R14,CRCCALC LA R0,2 R0 = size of CRC LA R1,CRCVAL R1 -> CRC BAL R14,HQXPUT Output data fork CRC L R0,=F'-1' R0 = -1 for cleanup BAL R14,HQXPUT HQXPUT final cleanup call * append final colon L R1,WRLEN Room for colon in buffer? C R1,=F'64' Yes, if length < 64 BL BINADDC BAL R14,HQXLINE Else write 64 bytes to file XC WRLEN(4),WRLEN and reset length BINADDC L R2,WRLEN R2 = no. of bytes in WRITBUFF L R1,=A(WRITBUFF) R1 -> start of buffer LA R3,0(R1,R2) R3 -> next location MVI 0(R3),C':' Store ending colon LA R2,1(R2) Store new length ST R2,WRLEN BAL R14,HQXLINE Output final line B RSCDONE Join common code EJECT * * HQXPUT - Apply HQX compression algorithm to binary data, and call * HQXEXP to expand up to 48 bytes of binary to up to 64 bytes * of printable characters. At entry R0 is the number of bytes * to process, and R1 contains their address. HQXPUT is called * with R0 < 0 for final cleanup. * HQXPUT DS 0H LTR R0,R0 Just return if zero bytes BZR R14 STM R0,R15,HPUTSAVE Save registers LR R2,R0 R2 = count for BCT * R1 -> current byte SR R3,R3 R3 = current CMPMODE IC R3,CMPMODE SR R4,R4 R4 = current HCMPCHAR IC R4,HCMPCHAR SR R5,R5 R5 = current CMPCOUNT IC R5,CMPCOUNT L R9,EXPLEN R9 = output length L R8,=A(EXPBUFF) R8 -> next output byte LA R8,0(R8,R9) LTR R2,R2 Ready for main loop if R2 > 0 BP HPUTLP * Else final cleanup call CLI CMPMODE,0 Done if mode = 0 BE HCLEND SR R1,R1 Set byte address to 0 LA R2,1 Set BCT count to 1 SR R6,R6 Get character in R6 IC R6,HCMPCHAR SR R7,R7 Get count in R7 IC R7,CMPCOUNT B HOUT Enter loop at output code SPACE HPUTLP EQU * Loop to process each character LTR R3,R3 Check for mode 1 BNZ HPUT1 * Else mode 0: HPUT0 EQU * Mode 0: initial mode IC R4,0(R1) Save current character LA R5,1 Set count to 1 LA R3,1 Set mode to 1 B HPUTNXT Ready for next byte SPACE HPUT1 EQU * Mode 1: checking for comp. CLM R4,B'0001',0(R1) New char. the same as prev.? BNE HDIFF No, go handle LA R5,1(R5) Increment count C R5,=F'255' Done if < 255 BL HPUTNXT LR R6,R4 R6 = char. to output LR R7,R5 R7 = count SR R3,R3 Mode = 0 (no prev. char.) B HOUT SPACE HDIFF EQU * New char. not same as prev. * Output previous character LR R6,R4 R6 = char. to output LR R7,R5 R7 = count to output IC R4,0(R1) Save current character LA R5,1 Set count to 1 HOUT EQU * Char. in R6, count in R7 LTR R7,R7 Done if count = 0 BZ HPUTNXT STC R6,0(R8) Append byte to buffer LA R8,1(R8) Increment pointer LA R9,1(R9) Increment count C R9,=F'48' Buffer full? BL HOUT2 No, check for X'90' ST R9,EXPLEN Store length for HQXEXP BAL R14,HQXEXP Call expansion routine L R8,=A(EXPBUFF) Reset pointer SR R9,R9 Reset count HOUT2 CLM R6,B'0001',=X'90' Is character X'90'? BNE HOUT3 No, check for repetition MVI 0(R8),0 Append zero byte LA R8,1(R8) Increment pointer LA R9,1(R9) Increment count C R9,=F'48' Buffer full? BL HOUT3 No, check for repetition ST R9,EXPLEN Store length for HQXEXP BAL R14,HQXEXP Call expansion routine L R8,=A(EXPBUFF) Reset pointer SR R9,R9 Reset count HOUT3 BCTR R7,0 Decrement count C R7,=F'2' If < 2 more, output w/o comp. BL HOUT * else output X'90', count MVI 0(R8),X'90' Append X'90' LA R8,1(R8) Increment pointer LA R9,1(R9) Increment count C R9,=F'48' Buffer full? BL HOUT4 No, ready for count ST R9,EXPLEN Store length for HQXEXP BAL R14,HQXEXP Call expansion routine L R8,=A(EXPBUFF) Reset pointer SR R9,R9 Reset count HOUT4 LA R7,1(R7) Restore original byte count STC R7,0(R8) Append byte count LA R8,1(R8) Increment pointer LA R9,1(R9) Increment count C R9,=F'48' Buffer full? BL HPUTNXT No, all done ST R9,EXPLEN Store length for HQXEXP BAL R14,HQXEXP Call expansion routine L R8,=A(EXPBUFF) Reset pointer SR R9,R9 Reset count HPUTNXT LA R1,1(R1) R1 -> next byte BCT R2,HPUTLP Decrement count and repeat L R2,HPUTSAVE Get original R0 LTR R2,R2 If <0, finish cleanup BM HCLEND ST R9,EXPLEN Store EXPBUFF length STC R3,CMPMODE Store CMPMODE STC R4,HCMPCHAR Store HCMPCHAR STC R5,CMPCOUNT Store CMPCOUNT HPUTRTN LM R0,R15,HPUTSAVE Restore registers BR R14 Return to caller SPACE HCLEND EQU * Output bytes left in EXPBUFF ST R9,EXPLEN Store length for HQXEXP C R9,=F'48' Check for zeros to add BE HNOZERO None if buffer full MVI 0(R8),0 Add one zero LA R8,1(R8) C R9,=F'47' Room for another? BE HNOZERO No, ready to output MVI 0(R8),0 Add another null HNOZERO BAL R14,HQXEXP Call expansion routine B HPUTRTN Ready to return SPACE HPUTSAVE DS 8D Local save area EJECT * * HQXEXP - Expand data in EXPBUFF to 6 bits in each byte. The length * is used from EXPLEN, and is assumed to not exceed 48. * Expanded data is translated and moved to WRITBUFF. HQXLINE * is called to output WRITBUFF as necessary. * HQXEXP STM R0,R15,HEXPSAVE Save registers SR R2,R2 R2, R3 = size of EXPBUFF data L R3,EXPLEN LTR R3,R3 If zero, just return BZ HEXPRTN D R2,=F'3' Divide to get 3-byte pieces LTR R2,R2 Check for any remainder BZ HNORM If none, keep count LA R0,1(R3) Piece count = quotient+1 SLL R3,2 Length = quotient*4 LA R3,1(R2,R3) + remainder + 1 LR R2,R0 Copy piece count to R2 B HCNT Continue with these counts SPACE HNORM LR R2,R3 R2 = count of pieces for BCT SLL R3,2 R3 = output length (count*4) HCNT L R4,=A(EXPBUFF) R4 -> start of input LA R5,HEXPBUFF R5 -> start of output HEXPLP EQU * Loop to expand pieces ICM R7,B'1110',0(R4) Get all 24 bits in R7 SR R6,R6 Get first 6 bits in R6 SLDL R6,6 STC R6,0(R5) Store first result byte SR R6,R6 Repeat for 2nd byte SLDL R6,6 STC R6,1(R5) SR R6,R6 Repeat for 3rd byte SLDL R6,6 STC R6,2(R5) SR R6,R6 Repeat for 4th byte SLDL R6,6 STC R6,3(R5) LA R4,3(R4) Increment input pointer LA R5,4(R5) Increment output pointer BCT R2,HEXPLP Repeat for piece count BCTR R3,0 Get length-1 for execute L R4,=A(BINTOASC) R4 -> binary-to-ASCII table EX R3,HEXPTR Convert binary to ASCII L R4,FRASCADR R4 -> ASCII-to-EBCDIC table EX R3,HEXPTR Convert ASCII to EBCDIC LA R3,1(R3) Restore original length LA R2,HEXPBUFF R2 -> first byte LA R5,64 R5 = bytes left in WRITBUFF S R5,WRLEN CR R3,R5 Will all bytes fit? BNH HEXWRCPY Yes, copy into buffer L R4,=A(WRITBUFF) R4 -> next output location A R4,WRLEN BCTR R5,0 R5 = length for EX EX R5,HEXPMVC Fill output buffer LA R4,64 Store new length ST R4,WRLEN BAL R14,HQXLINE Output buffer to file XC WRLEN(4),WRLEN Reset length LA R5,1(R5) Get actual count moved SR R3,R5 R3 = bytes still to move LA R2,0(R2,R5) R2 -> next byte to move HEXWRCPY L R4,=A(WRITBUFF) R4 -> next output location A R4,WRLEN BCTR R3,0 R3 = length for EX EX R3,HEXPMVC Move bytes to output buffer L R4,WRLEN Update buffer size LA R4,1(R3,R4) ST R4,WRLEN C R4,=F'64' Is buffer full now? BNE HEXPRTN No, ready to return BAL R14,HQXLINE Output full buffer XC WRLEN(4),WRLEN Reset buffer length HEXPRTN LM R0,R15,HEXPSAVE Restore registers BR R14 Return to caller SPACE HEXPSAVE DS 8D Local save area HEXPBUFF DS 8D Local buffer for expansion HEXPTR TR HEXPBUFF(*-*),0(R4) HEXPMVC MVC 0(*-*,R4),0(R2) EJECT * * HQXLINE - Write contents of WRITBUFF to output file. The current * length of the data in WRITBUFF is given in WRITLEN. * Returns to caller if no error; otherwise types an error * message and returns directly to CMS. * HQXLINE DS 0H STM R0,R15,HQXLSAVE Save registers L R2,WRITEM Increment line number LA R2,1(R2) ST R2,WRITEM OI FLAGS,WROPEN Remember file is open MVC WRBUFLTH(4),WRLEN Set line length from buffer size LA R1,OUTPLIST R1 -> PLIST L R15,AWRBUF R15 -> WRBUF entry BALR R14,R15 Call WRBUF BZ HQXLRET If ok, ready to return LR R2,R15 Copy error code to R2 DMSERR LET=S,NUM=105, X TEXT='Error ''..'' writing file ''....................''X on disk',SUB=(DEC,(R2),CHAR8A,OFN),RENT=NO LA R2,100(R2) Set RC = 1nn ST R2,RTNCODE Set code to return B CMSRTN Direct return to CMS SPACE HQXLRET LM R0,R15,HQXLSAVE Restore registers BR R14 Return to caller SPACE HQXLSAVE DS 8D Local save area EJECT * * GETSTR - Fill buffer with bytes from input file. At entry, * R0 contains the buffer size and R1 contains the buffer * address. If any errors occur, GETSTR generates an * error message and returns to CMS. * GETSTR DS 0H STM R0,R15,GSSAVE Save registers LR R4,R0 R4 = buffer size LR R5,R1 R5 -> buffer GSAGAIN LTR R4,R4 Buffer size = 0? BZ GSRTN If so, just return CLI CMPCNT,0 Compressed data to return? BNE GSUSECMP Yes, go use it L R6,BINLEN R6 = count of bytes left L R7,=A(BINBUFF) R7 -> next byte A R7,BINOFF LTR R6,R6 Any bytes left? BP GSUSEBIN Yes, go use them MVC GSPREV(1),BINLAST Save last byte from current line BAL R14,GTBINLIN Read more binary data LTR R15,R15 Any error? BZ GSAGAIN No, use data B GSEOF Else return EOF SPACE GSUSEBIN EQU * Process data in BINBUFF LA R1,0(R6,R7) R1 -> past last byte LR R3,R6 R3 = length-1 for TRT BCTR R3,0 L R8,=A(CMPTAB) R8 -> TRT table EX R3,CMPTRT Scan for X'90' in BINBUFF SR R1,R7 R1 = length before X'90' BZ GSCMPINI If none, set up for compression NI FLAGS,255-X90DATA X90 data byte no longer current CR R1,R4 Longer than needed? BNH GSMVDATA No, keep length LR R1,R4 Else reduce to length needed GSMVDATA BCTR R1,0 Decrement length for EX EX R1,DATAMVC Move data to caller's buffer LA R1,1(R1) Restore actual length SR R4,R1 Decrement buffer size LA R5,0(R1,R5) Increment buffer address L R2,BINLEN Decrement binary length SR R2,R1 ST R2,BINLEN L R2,BINOFF Increment binary offset AR R2,R1 ST R2,BINOFF B GSAGAIN Check for more to do SPACE GSCMPINI EQU * R7 -> X'90' * Get compression character TM FLAGS,X90DATA Have character from last X'90'? BO USEX90 Yes, use it L R1,BINOFF Is X'90' at start of line LTR R1,R1 If so, use byte from previous line BZ USEPREV LR R1,R7 Else use previous byte on line BCTR R1,0 R1 -> byte to use B STCMPCHR SPACE USEX90 LA R1,X90CHAR R1 -> byte from last X90 B STCMPCHR SPACE USEPREV LA R1,GSPREV R1 -> byte to use STCMPCHR MVC CMPCHAR(1),0(R1) Store byte to replicate OI FLAGS,X90DATA Set flag for X90 data MVC X90CHAR(1),0(R1) Save X90 data byte C R6,=F'1' Is count available after X'90'? BNH GSRDCNT No, go read it MVC CMPCNT(1),1(R7) Store compression count L R2,BINOFF Increment binary offset LA R2,2(R2) ST R2,BINOFF L R2,BINLEN Decrement binary length BCTR R2,0 BCTR R2,0 ST R2,BINLEN B CHKCMP Ready to check what we have SPACE GSRDCNT BAL R14,GTBINLIN Read more binary data LTR R15,R15 Any error? BNZ GSEOF Yes, return EOF L R6,BINLEN Update R6, R7 for new read L R7,=A(BINBUFF) A R7,BINOFF MVC CMPCNT(1),0(R7) Store compression count L R2,BINOFF Increment binary offset LA R2,1(R2) ST R2,BINOFF L R2,BINLEN Decrement binary length BCTR R2,0 ST R2,BINLEN CHKCMP CLI CMPCNT,0 New count = 0? BNE GSDECCMP No, adjust count to be length MVI X90CHAR,X'90' Data byte is now X'90' MVI 0(R5),X'90' Return X'90' BCTR R4,0 Decrement buffer size LA R5,1(R5) Increment buffer pointer B GSAGAIN See if more to do SPACE GSDECCMP SR R1,R1 Get count in R1 IC R1,CMPCNT BCTR R1,0 Decrement to get replication count STC R1,CMPCNT LTR R1,R1 If zero, start again BNP GSAGAIN GSUSECMP SR R1,R1 R1 = compression count IC R1,CMPCNT LR R2,R1 Save in R2 CR R1,R4 Count bigger than buffer size? BNH CMPCPY No, keep count LR R1,R4 Else reduce to buffer size CMPCPY SR R2,R1 R2 = remaining count STC R2,CMPCNT Store remaining count LR R8,R1 Save count in R8 LR R0,R5 R0 -> destination * R1 = destination length SR R2,R2 R2 -> source (none) SR R3,R3 R3 = source length (zero) ICM R3,B'1000',CMPCHAR Pad char. = compression char. MVCL R0,R2 Store duplicated characters SR R4,R8 Decrement buffer size LA R5,0(R5,R8) Increment buffer pointer B GSAGAIN Check for more to do SPACE GSRTN LM R0,R15,GSSAVE Restore registers BR R14 Return to caller SPACE GSEOF DMSERR NUM=6,LET=E, X TEXT='Unexpected end-of-file reading ''.................X ...''',SUB=(CHAR8A,IFN) MVI RTNCODE+3,36 CMS RC = 36 B CMSRTN SPACE GSSAVE DS 8D Local save area CMPTRT TRT 0(*-*,R7),0(R8) TRT for X'90' DATAMVC MVC 0(*-*,R5),0(R7) Move binary data to buffer GSPREV DS 1X Last byte from previous line X90CHAR DS 1X Data byte for last X'90' EJECT * * GTBINLIN - Convert data in READBUFF to binary data in BINBUFF * (HQX files only). The length is returned in BINLEN. * Returns R15=0 (ok) or R15=12 (eof). * GTBINLIN DS 0H STM R0,R15,GBSAVE Save registers GBAGAIN BAL R14,GETLINE Get more data from file ST R15,GBSAVE+60 Store return code LTR R15,R15 Return if non-zero BNZ GBRET XC BINOFF(4),BINOFF Reset offset for reading result L R1,=A(READBUFF) R1 -> first byte A R1,RDOFF L R2,RDLGTH R2 = length L R3,=A(BINBUFF) R3 -> output buffer SR R4,R4 R4 = output length LA R5,CVCNT0 R5 = addr. for checking zero bits GBINILP EQU * Loop until no bits left over or EOF LTR R2,R2 Any bytes left? BZ GBEND No, ready to return C R5,BINXTADR No bits left over? BE GBGROUP Yes, do groups of bytes BAL R14,CVTBYTE Convert next byte STC R0,0(R3) Store output byte LA R3,1(R3) Increment address LA R4,1(R4) Increment length LA R1,1(R1) Increment pointer BCTR R2,0 Decrement length B GBINILP Repeat SPACE * Process groups of 8 input byte to get 6 binary bytes GBGROUP LR R5,R2 Get count of groups SRL R5,3 = byte count/8 LTR R5,R5 Any groups? BZ GBFIN No, loop for any bytes left SR R8,R8 R8 = 0 for IC LA R0,1 R0 = 1 for increments GBGRLP EQU * Loop to process groups LA R9,8 R9 = byte count for loop GBG1LP EQU * Loop for 1 group IC R8,0(R1) Get new byte SLDL R6,6 Make room for new bits OR R7,R8 OR-in bits AR R1,R0 R1 -> next byte BCT R9,GBG1LP Repeat for 8 bytes S R2,=F'8' Decrement bytes left STCM R6,B'0011',0(R3) Store result bytes STCM R7,B'1111',2(R3) LA R3,6(R3) Increment output address LA R4,6(R4) Increment output length BCT R5,GBGRLP Loop for all groups * Loop to process any remaining bytes GBFIN LTR R2,R2 Any bytes left? BZ GBEND No, ready to return GBENDLP EQU * Loop to process remaining bytes BAL R14,CVTBYTE Convert next byte LTR R0,R0 Result byte returned? BM GBENDNXT No, skip saving byte STC R0,0(R3) Store output byte LA R3,1(R3) Increment address LA R4,1(R4) Increment length GBENDNXT LA R1,1(R1) Increment pointer BCT R2,GBENDLP SPACE * Return to caller GBEND LTR R4,R4 Non-zero length to return? BZ GBAGAIN No, read next line ST R4,BINLEN Store output length L R3,=A(BINBUFF) R4 -> last byte LA R3,0(R3,R4) BCTR R3,0 MVC BINLAST(1),0(R3) Save in case part of compression GBRET LM R0,R15,GBSAVE Restore registers, RC in R15 BR R14 SPACE GBSAVE DS 8D Local save area EJECT * * CVTBYTE - Read next byte using address in R1 and any left over bits * in BINEXTRA. Return a new byte in R0, and set BINEXTRA * and BINXTADR as appropriate. Return R0=-1 if more bits * are needed to make a byte. * CVTBYTE DS 0H STM R0,R15,CVSAVE Save registers and RC L R2,BINXTADR Get addr. for processing BR R2 Branch for left over bits SPACE CVCNT0 EQU * No bits left over IC R3,0(R1) New bits in R3 LA R1,CVCNT6 Set 6 bits left over ST R1,BINXTADR L R0,=F'-1' Return -1 in R0 STC R3,BINEXTRA Store left over bits B CVRTN SPACE CVCNT6 EQU * 6 bits left from last time SR R2,R2 Left over bits in R2 IC R2,BINEXTRA IC R3,0(R1) New bits in R3 SLL R3,26 Make new bits most significant SLDL R2,2 Get new byte in R2 SRL R3,28 Get left over bits in R3 LA R1,CVCNT4 Set 4 bits left over ST R1,BINXTADR LR R0,R2 Return byte in R0 STC R3,BINEXTRA Store left over bits B CVRTN Ready to return SPACE CVCNT4 EQU * 4 bits left from last time SR R2,R2 Left over bits in R2 IC R2,BINEXTRA IC R3,0(R1) New bits in R3 SLL R3,26 Make new bits most significant SLDL R2,4 Get new byte in R2 SRL R3,30 Get left over bits in R3 LA R1,CVCNT2 Set 2 bits left over ST R1,BINXTADR LR R0,R2 Return byte in R0 STC R3,BINEXTRA Store left over bits B CVRTN Ready to return SPACE CVCNT2 EQU * 2 bits left from last time SR R2,R2 Left over bits in R2 IC R2,BINEXTRA IC R3,0(R1) New bits in R3 SLL R3,26 Make new bits most significant SLDL R2,6 Get new byte in R2 LA R1,CVCNT0 Set 0 bits left over ST R1,BINXTADR LR R0,R2 Return byte in R0 * B CVRTN Ready to return SPACE CVRTN LM R1,R15,CVSAVE+4 Restore all but result in R0 BR R14 Return to caller SPACE CVSAVE DS 8D Local save area EJECT * * GETLINE - Read the next line of the input file into READBUFF. * The length is returned in RDLGTH and the starting * offset is returned in RDOFF. For HQX files, data is * returned between a starting colon in column one of a * line, and an ending colon. Also, data is translated * to six-bit binary. * Return R15=0 (ok) or R15=12 (eof). * GETLINE DS 0H STM R0,R15,GLSAVE Save registers GLAGAIN TM FLAGS,HQXEOF EOF set from last time? BO GLEOFRET Yes, return eof L R1,RDITEM Increment line number LA R1,1(R1) ST R1,RDITEM XC RDOFF(4),RDOFF Reset read offset OI FLAGS,RDOPEN Remember input file is open LA R1,INPLIST R1 -> PLIST L R15,ARDBUF R15 -> RDBUF entry BALR R14,R15 Call RDBUF ST R15,GLSAVE+60 Return RC in R15 BZ GLRDOK RC 0 is normal C R15,=F'12' RC 12 is eof BE GLRET * Else unexpected error LR R2,R15 Copy error code to R2 DMSERR LET=S,NUM=104, X TEXT='Error ''..'' reading file ''....................''X from disk',SUB=(DEC,(R2),CHAR8A,IFN),RENT=NO LA R2,100(R2) Set RC = 1nn ST R2,RTNCODE B CMSRTN Direct return to CMS SPACE GLRDOK CLC RDLGTH(4),=F'0' Any bytes read? BE GLAGAIN No (very strange); try again L R1,CHRTOTAL Increment character count A R1,RDLGTH ST R1,CHRTOTAL TM FLAGS,MACBIN If reading MacBinary, all done BO GLRET * For HQX file, adjust length to delete trailing blanks L R1,RDLGTH R1 = count for BCT L R2,=A(READBUFF) R2 -> last byte LA R2,0(R1,R2) R2 -> last byte BCTR R2,0 GLTRLOOP EQU * Loop to truncate blanks CLI 0(R2),C' ' Found non-blank? BNE GLTREND Yes, done BCTR R2,0 R2 -> previous byte BCT R1,GLTRLOOP Repeat for line length B GLAGAIN If all blank, read next line SPACE GLTREND ST R1,RDLGTH Store adjusted line length * For HQX file, handle initial colon TM FLAGS,HQXCOLON Colon in previous line? BO GLHQXCNT Yes, continue L R2,=A(READBUFF) Does this line start with colon? CLI 0(R2),C':' BNE GLAGAIN No, try again OI FLAGS,HQXCOLON Remember have found colon BCTR R1,0 Decrement line length LTR R1,R1 Zero now? BZ GLAGAIN Yes, get next line ST R1,RDLGTH Store new length LA R2,1 Initial offset = 1 ST R2,RDOFF * For HQX file, check for ending colon or invalid character GLHQXCNT L R3,=A(READBUFF) R3 -> first byte A R3,RDOFF L R4,RDLGTH R4 = length BCTR R4,0 Decrement length for EX SR R1,R1 Initialize R1 before TRT L R5,=A(VALIDTAB) R5 -> TRT table EX R4,HQXTRT Scan for invalid character BZ GLHQXTR Ready to translate if none OI FLAGS,HQXEOF Remember EOF for HQX file MVC EOFCHAR(1),0(R1) Save character we stopped at LA R2,1(R1) Save character position in line L R4,=A(READBUFF) SR R2,R4 ST R2,EOFPOS SR R1,R3 R1 = new length ST R1,RDLGTH Store new length BNP GLEOFRET Return EOF if not positive * For HQX file, translate EBCDIC to 6-bit binary GLHQXTR L R1,RDLGTH R1 = length BCTR R1,0 Decrement for EX L R2,=A(READBUFF) R2 -> first byte A R2,RDOFF L R3,TOASCADR R3 -> EBCDIC-to-ASCII table EX R1,GLTR Translate data to ASCII L R3,=A(ASCTOBIN) R3 -> ASCII-to-binary table EX R1,GLTR Translate ASCII to binary * Return to caller GLRET LM R0,R15,GLSAVE Restore registers, RC in R15 BR R14 SPACE GLEOFRET CLI EOFCHAR,C':' Stopped at a colon? BNE GLBADCHR No, give error message LA R15,12 Else return normal eof LM R0,R14,GLSAVE BR R14 SPACE GLBADCHR DMSERR LET=E,NUM=5,TEXT='Invalid character ''..'' in ''.......X .............'' at line .......... position ...', X RENT=NO,SUB=(CHARA,(EOFCHAR,1),CHAR8A,IFN,DECA,RDITEM,DEX CA,EOFPOS) MVI RTNCODE+3,36 Set RC = 36 B CMSRTN Direct return to CMS SPACE GLSAVE DS 8D Local save area HQXTRT TRT 0(*-*,R3),0(R5) TRT to check valid characters GLTR TR 0(*-*,R2),0(R3) Translate to ASCII or binary EJECT * * WR128 - Write 128 bytes of data to a MacBinary output file. * At entry, R1 -> 128 bytes to be written. * WR128 DS 0H STM R0,R15,WRSAVE Save registers L R2,WRITEM Increment line number LA R2,1(R2) ST R2,WRITEM OI FLAGS,WROPEN Remember output file is open ST R1,WRADDR Store buffer address LA R1,OUTPLIST R1 -> PLIST L R15,AWRBUF R15 -> WRBUF entry BALR R14,R15 Call WRBUF BZ WRRET If ok, ready to return LR R2,R15 Copy error code to R2 DMSERR LET=S,NUM=105, X TEXT='Error ''..'' writing file ''....................''X on disk',SUB=(DEC,(R2),CHAR8A,OFN),RENT=NO LA R2,100(R2) Set RC = 1nn ST R2,RTNCODE B CMSRTN Direct return to CMS SPACE WRRET LM R0,R15,WRSAVE Restore registers BR R14 Return to caller SPACE WRSAVE DS 8D Local save area EJECT * * CRCCALC - Update CRCVAL for a string. At entry, R0 = string length * and R1 -> string. * CRCCALC DS 0H STM R0,R15,CRCSAVE Save registers LTR R7,R0 R7 = BCT count BZ CRCRTN If zero, just return LR R6,R1 R6 -> first byte SR R3,R3 R3 = current CRC ICM R3,B'1100',CRCVAL (in msb) L R4,=V(XMDMTAB) R4 -> CRC table SR R5,R5 R5 = 0 for table entries CRCLOOP EQU * Loop for each character SR R2,R2 Shift CRC and get old SLDL R2,8 msb in R2 ICM R3,B'0100',0(R6) Append new byte to CRC SLL R2,1 R2 = table offset LA R2,0(R2,R4) R2 -> table entry ICM R5,B'1100',0(R2) R5 = table entry XR R3,R5 update CRC LA R6,1(R6) R6 -> next byte BCT R7,CRCLOOP Repeat to end of string STCM R3,B'1100',CRCVAL Store final CRC CRCRTN LM R0,R15,CRCSAVE Restore registers BR R14 Return to caller SPACE CRCSAVE DS 8D Local save area EJECT * * Error message code * SPACE STATERR ST R15,RTNCODE Save return code from STATE LA R2,8(R1) R2 -> filename in PLIST C R15,=F'28' Return if STATE typed message BL CMSRTN BE STNOFIL RC = 28 is file not found * Else disk not accessed (RC = 36) LA R2,16(R2) R2 -> filemode in plist DMSERR NUM=69,LET=E,TEXT='Disk ''..'' not accessed', X SUB=(CHARA,((R2),1)) B CMSRTN SPACE STNOFIL DMSERR NUM=2,LET=E, X TEXT='File ''....................'' not found', X SUB=(CHAR8A,(R2)) B CMSRTN SPACE LRECLERR MVI RTNCODE+3,32 Set RC = 32 DMSERR NUM=44,LET=E,TEXT='Record length exceeds allowable maxiX mum' B CMSRTN SPACE EXIERR LTR R15,R15 If non-zero RC, handle STATE error BNZ STATERR LA R2,8(R1) R2 -> filemame in plist DMSERR NUM=24,LET=E, X TEXT='File ''....................'' already exists', X SUB=(CHAR8A,(R2)) MVI RTNCODE+3,28 B CMSRTN SPACE ROERR EQU * USING ADTSECT,R2 LA R2,ADTM Point to mode letter DROP R2 DMSERR NUM=37,LET=E,TEXT='Disk ''..'' is read-only', X SUB=(CHARA,((R2),1)) MVI RTNCODE+3,36 B CMSRTN SPACE CMSRTN EQU * Return to CMS TM FLAGS,RDOPEN Is input file open? BZ RTN0 No, skip finis L R15,AFINIS LA R1,INPLIST BALR R14,R15 Close input file RTN0 TM FLAGS,WROPEN Is output file open? BZ RTN1 No, skip finis L R15,AFINIS LA R1,OUTPLIST BALR R14,R15 Close output file RTN1 DMSKEY RESET Restore user key SSM =X'FF' Allow interrupts L R15,RTNCODE R15 = return code LM R0,R14,REGSAVE Restore other registers BR R14 Return to caller EJECT * * GETID - Invoke IDENTIFY to get local node id. Set the * node id to blanks if any error. * SPACE GETID DS 0H STM R14,R1,GETSAVE Save registers MVC NODEID(8),=CL8' ' Initialize node id to blanks LA R1,IDPLIST Execute IDENTIFY SVC 202 DC AL4(1) LTR R15,R15 Just return if any errors BNZ GETIDRTN RDTERM RDRESP Get response C R0,=F'19' At least 19 bytes? BL GETIDRTN No, just return MVC NODEID(8),RDRESP+12 Copy node id from IDENTIFY GETIDRTN LM R14,R1,GETSAVE Restore registers BR R14 Return SPACE GETSAVE DS 2D Save area: R14, R15, R0, R1 IDPLIST DS 0D DC CL8'IDENTIFY' IDENTIFY command DC CL8'(' DC CL8'LIFO' DC 8X'FF' RDRESP DS CL130 RDTERM buffer EJECT * * DECCVT -- Convert decimal number in plist to binary * * Entry: R1 -> 8-byte number, R14 = return address * Exit: R2 = -1 if conversion error, or contains binary number; * condition code set from R2 * DECCVT DS 0H STM R3,R1,DECSAVE Save registers SR R2,R2 Result = 0 LA R3,8 Examine 8 bytes SR R4,R4 R4 = 0 for IC * R1 -> first byte of token DECLOOP EQU * Scan number and accumulate result CLI 0(R1),C' ' Exit when blank encountered BE DECEND CLI 0(R1),C'0' Check for a valid digit BL DECERR CLI 0(R1),C'9' BH DECERR IC R4,0(R1) Get binary digit in R4 SH R4,=H'240' MH R2,=H'10' Result = 10*result + digit AR R2,R4 LA R1,1(R1) R1 -> next digit BCT R3,DECLOOP Repeat B DECEND Skip error result DECERR LH R2,=H'-1' Error: return -1 DECEND LM R3,R1,DECSAVE Restore all registers except R2 LTR R2,R2 Set condition code for caller BR R14 Return to caller SPACE DECSAVE DS 8D Save area R3...R15, R0, R1 EJECT * * NUMTOSTR - Store character form of a number in a buffer. * At entry, R0 contains the number and R1 points to * the buffer. Returns the length of the string * stored in R0. * NUMTOSTR DS 0H STM R0,R15,NUMSAVE Save registers CVD R0,NUMBUF Convert number to decimal TM FLAGS2,EXECVAR+NOCOMMA Check if commas not wanted BNZ ALTEDIT MVC EDITBUFF(15),EDITPAT Copy pattern for EDMK LA R1,EDITBUFF+14 R1 -> last byte EDMK EDITBUFF(15),NUMBUF+2 Convert to characters LA R2,EDITBUFF+15 R2 -> past last byte B NUMEND SPACE ALTEDIT MVC EDITBUFF(12),EDITPAT2 Copy pattern for EDMK LA R1,EDITBUFF+11 R1 -> last byte EDMK EDITBUFF(12),NUMBUF+2 Convert to characters LA R2,EDITBUFF+12 R2 -> past last byte NUMEND SR R2,R1 Get length in R2 ST R2,NUMSAVE Store to return in R0 BCTR R2,0 Decrement for EX L R3,NUMSAVE+4 R3 -> buffer EX R2,NUMMVC Copy number to buffer LM R0,R15,NUMSAVE Return to caller BR R14 SPACE NUMSAVE DS 8D Local save area NUMBUF DS 1D Buffer for CVD NUMMVC MVC 0(*-*,R3),0(R1) Copy number to buffer EDITPAT DC X'4020206B2020206B2020206B202120' EDIT pattern EDITPAT2 DC X'402020202020202020202120' alternate pattern EDITBUFF DS 15C Buffer for EDIT result EJECT * * SEC2DATE - Store the character form of a Macintosh date in a * buffer. At entry, R0 contains the number of seconds * since midnight, Jan. 1, 1904. R1 points to the buffer * which will contains the date. The length of the date * is returned in R0. * SEC2DATE DS 0H STM R0,R15,SECSAVE Save registers OI FLAGS2,NOCOMMA Suppress commas for NUMTOSTR * Get elapsed days, hours, minutes, seconds LR R1,R0 R0, R1 = total seconds SR R0,R0 D R0,=F'86400' Divide to get days ST R1,SECDAYS Store elapsed days LR R1,R0 R0, R1 = remaining seconds SR R0,R0 D R0,=F'3600' Divide to get hours ST R1,SECHRS Store elapsed hours LR R1,R0 R0, R1 = remaining seconds SR R0,R0 D R0,=F'60' Divide to get mins, seconds ST R1,SECMIN Store elpased minutes ST R0,SECSEC Store elpased seconds * Calculate day of the week SR R0,R0 Divide days by 7 L R1,SECDAYS D R0,=F'7' ST R0,SECWKDAY Store remainder * Calculate month, day and year from elapsed days L R3,SECDAYS R3 = elapsed days A R3,=F'1401' Add constant to get days from * March 1, 1900 * Get 4*Jdate + 3 SLL R3,2 LA R3,3(R3) SR R2,R2 Divide by 1461 D R2,=F'1461' * R2 = day, R3 = year SRL R2,2 Day = day/4 + 1 LA R2,1(R2) MH R2,=H'5' Get (5*day-3)/153 S R2,=F'3' SR R4,R4 LR R5,R2 D R4,=F'153' * R4 = day, R5 = month LR R2,R5 R2 = month SR R0,R0 Day = day/5 + 1 LR R1,R4 D R0,=F'5' LA R1,1(R1) R1 = day, R2 = month, R3 = year LA R2,3(R2) Month = Month + 3 C R2,=F'12' If > 12, subtract 12 BNH KEEPMON S R2,=F'12' LA R3,1(R3) And add 1 to year KEEPMON EQU * ST R1,SECDAY Store day of month ST R2,SECMONTH Store month LA R3,1900(R3) Add base year to year ST R3,SECYEAR * Format results in character string form SR R2,R2 R2 = string length L R3,SECSAVE+4 R3 -> next available byte L R1,SECWKDAY R1 = weekday (0 - 6) MH R1,=H'3' Convert to table offset LA R1,DAYLIST(R1) R1 -> weekday MVC 0(3,R3),0(R1) Copy weekday MVC 3(2,R3),=C', ' Append separator L R1,SECMONTH R1 = month (1 - 12) BCTR R1,0 Convert to table offset MH R1,=H'3' LA R1,MONLIST(R1) R1 -> month MVC 5(3,R3),0(R1) Copy month MVI 8(R3),C' ' Append separator LA R2,9(R2) Increment length LA R3,9(R3) Increment pointer L R0,SECDAY R0 = day of the month LR R1,R3 R1 -> buffer BAL R14,NUMTOSTR Store string in buffer AR R2,R0 Increment length AR R3,R0 Increment pointer MVC 0(2,R3),=C', ' Append separator LA R2,2(R2) Increment length LA R3,2(R3) Increment pointer L R0,SECYEAR R0 = year LR R1,R3 R1 -> buffer BAL R14,NUMTOSTR Store string in buffer AR R2,R0 Increment length AR R3,R0 Increment pointer MVC 0(2,R3),=C' ' Append separator LA R2,2(R2) Increment length LA R3,2(R3) Increment pointer L R0,SECHRS R0 = hours (0 - 23) C R0,=F'12' Morning if < 12 BL SECAM * Else afternoon MVC AMPM(2),=C'PM' Store "PM" C R0,=F'12' If hours = 12, keep BE PMKEEP S R0,=F'12' Else subtract 12 PMKEEP B USEHRS Ready to format hours SPACE SECAM MVC AMPM(2),=C'AM' Store "AM" LTR R0,R0 Use hours if > 0 BNZ USEHRS LA R0,12 Else set hours to 12 USEHRS LR R1,R3 R1 -> buffer BAL R14,NUMTOSTR Store string in buffer AR R2,R0 Increment length AR R3,R0 Increment pointer L R0,SECMIN R0 = minutes AH R0,=H'100' Add 100 to use 3 columns LR R1,R3 R1 -> buffer BAL R14,NUMTOSTR Store string in buffer MVI 0(R3),C':' Replace "1" by ":" AR R2,R0 Increment length AR R3,R0 Increment pointer L R0,SECSEC R0 = seconds AH R0,=H'100' Add 100 to use 3 columns LR R1,R3 R1 -> buffer BAL R14,NUMTOSTR Store string in buffer MVI 0(R3),C':' Replace "1" by ":" AR R2,R0 Increment length AR R3,R0 Increment pointer MVI 0(R3),C' ' Append separator MVC 1(2,R3),AMPM Append AM or PM LA R2,3(R2) R2 = final length ST R2,SECSAVE Store to return in R0 NI FLAGS2,255-NOCOMMA Reset comma suppression LM R0,R15,SECSAVE Restore registers BR R14 Return to caller SPACE SECSAVE DS 8D Local save area SECDAYS DS 1F Elapsed days SECHRS DS 1F Elapsed hours SECMIN DS 1F Elapsed minutes SECSEC DS 1F Elapsed seconds SECWKDAY DS 1F Weekday (0 = Fri, 1 = Sat ...) SECDAY DS 1F Day of the month SECMONTH DS 1F Month SECYEAR DS 1F Year DAYLIST DC C'FriSatSunMonTueWedThu' MONLIST DC C'JanFebMarAprMayJunJulAugSepOctNovDec' AMPM DS 2C EJECT * * TYPEHDR - Type description of header information * TYPEHDR DS 0H STM R0,R15,TYPHDSAV Save registers L R8,=A(DATABUFF) R8 -> message buffer LINEDIT TEXT='File: ''....................''',RENT=NO, X SUB=(CHAR8A,IFN),DOT=NO,BUFFA=(R8),DISP=NONE SR R2,R2 R2 = message length IC R2,0(R8) LA R3,1(R2,R8) R3 -> next byte MVC 0(10,R3),=C' Format: ' Append format info. TM FLAGS,MACBIN Check for MacBinary BO FMTBIN MVC 10(6,R3),=C'BinHex' Else BinHex format LA R2,16(R2) Get new length B TYPEFMT Ready to type line SPACE FMTBIN MVC 10(9,R3),=C'MacBinary' MacBinary format LA R2,19(R2) Get new length TYPEFMT STC R2,0(R8) Store new length BAL R14,TYPEDESC Type or stack line MVC 1(11,R8),=C'Filename: ''' Generate filename msg. MVC 12(63,R8),HDFN append filename L R2,FRASCADR translate to EBCDIC TR 12(63,R8),0(R2) SR R1,R1 Get length of filename IC R1,HDFNLEN LA R1,12(R1) Add length of message STC R1,0(R8) Store length for TYPEDESC LA R1,0(R1,R8) R1 -> past filename MVI 0(R1),C'''' Append apostrophe BAL R14,TYPEDESC Type or stack line MVC 1(7,R8),=C'Type: ''' Generate type, MVC 8(4,R8),HDFTYP creator message TR 8(4,R8),0(R2) Translate to EBCDIC MVC 12(13,R8),=C''' Creator: ''' MVC 25(4,R8),HDFCREAT TR 25(4,R8),0(R2) Translate to EBCDIC MVC 29(10,R8),=C''' Flags: ' ICM R3,B'1100',HDFLAGS Get flags in msb of R3 LA R4,FLAGTEXT R4 -> list of names LA R5,16 R5 = bit count LA R6,39 R6 = buffer offset FLGLOOP EQU * Loop to set flag names SR R2,R2 Get next bit in R2 SLDL R2,1 LTR R2,R2 Is bit set? BZ FLGNEXT No, skip name C R6,=F'39' First name? BE SKIPPLUS Yes, skip "+" IC R7,=C'+' Else append "+" STC R7,0(R6,R8) LA R6,1(R6) SKIPPLUS LA R7,0(R6,R8) R7 -> where to put text MVC 0(4,R7),0(R4) Copy flag name LA R6,4(R6) FLGNEXT LA R4,4(R4) R4 -> next name BCT R5,FLGLOOP C R6,=F'39' Any flags? BNE HAVEFLGS Yes, continue LA R7,0(R6,R8) Else append "none" MVC 0(4,R7),=C'none' LA R6,4(R6) HAVEFLGS BCTR R6,0 R6 = line length STC R6,0(R8) Store for TYPEDESC BAL R14,TYPEDESC Type or stack line ICM R3,B'1111',HDDATALN Get data fork length ICM R4,B'1111',HDRSCLN Get resource fork length MVC 1(16,R8),=C'Data fork size: ' Copy start of size LA R5,16 R5 = message length LA R6,1(R5,R8) R6 -> next byte LR R0,R3 R0 = data size LR R1,R6 R1 -> buffer BAL R14,NUMTOSTR Store number in string form AR R5,R0 Update length and address AR R6,R0 MVC 0(22,R6),=C'; Resource fork size: ' Copy rest LA R5,22(R5) Update length and address LA R6,22(R6) LR R0,R4 R0 = resource size LR R1,R6 R1 -> buffer BAL R14,NUMTOSTR Store number in string form AR R5,R0 Update length STC R5,0(R8) Store length for TYPEDESC BAL R14,TYPEDESC Type or stack line TM FLAGS,MACBIN MacBinary file? BZ TYPHEND No, all info. typed MVC 1(15,R8),=C' Created: ' Start of creation date LA R5,15 R5 = message length LA R1,1(R5,R8) R1 -> next byte ICM R0,B'1111',HDCRDATE R0 = creation date BAL R14,SEC2DATE Store date in character form AR R5,R0 Update length STC R5,0(R8) Store length for TYPEDESC BAL R14,TYPEDESC Type or stack line MVC 1(15,R8),=C'Last Modified: ' Start of last mod date LA R5,15 R5 = message length LA R1,1(R5,R8) R1 -> next byte ICM R0,B'1111',HDMDDATE R0 = creation date BAL R14,SEC2DATE Store date in character form AR R5,R0 Update length STC R5,0(R8) Store length for TYPEDESC BAL R14,TYPEDESC Type or stack line TYPHEND LA R1,=CL8'CONWAIT' Call CONWAIT to wait for SVC 202 output to finish DC AL4(1) (following code can take a while) LM R0,R15,TYPHDSAV Restore registers BR R14 Return to caller SPACE TYPHDSAV DS 8D Local save area EJECT * * TYPEDESC - Type a description line or stack the line (depending * on the options the user has specified). The first byte * of DATABUFF contains the line length, and is followed * by the text. * TYPEDESC DS 0H STM R0,R15,TYPSAVE Save registers L R2,=A(DATABUFF) R2 -> string length byte SR R1,R1 Get length in R1 IC R1,0(R2) TM FLAGS,STKDESC Stacking requested? BO DOSTACK Yes, go do it STH R1,TYPLEN Store length for typing LA R1,TYPLIST R1 -> TYPLIN plist SVC 202 Type the line DC AL4(1) Ignore errors B TYPRTN Return SPACE DOSTACK MVI STKORDR,C'F' Set FIFO default order TM FLAGS,STKLIFO LIFO wanted? BZ KEEPFIFO No, keep FIFO MVI STKORDR,C'L' Else change FIFO to LIFO KEEPFIFO STC R1,STKLEN Store length for stacking LA R1,STKLIST R1 -> ATTN plist SVC 202 Stack the line DC AL4(1) Ignore errors TYPRTN LM R0,R15,TYPSAVE Restore registers BR R14 Return to caller SPACE TYPSAVE DS 8D Local save area EJECT * * VARHDR - Return header information in REXX variables. VARHDR * is called instead of TYPEHDR when the STEM option has * been specified. * VARHDR DS 0H STM R0,R15,VARSAVE Save registers L R8,=A(DATABUFF) R8 -> buffer for values L R1,=A(VARTAB) R1 -> FN string data MVI 0(R8),8 Store filename length MVC 1(8,R8),IFN Copy filename BAL R14,SETVAR Define stem.FN LA R1,4(R1) R1 -> FT string data MVI 0(R8),8 Store filetype length MVC 1(8,R8),IFT Copy filetype BAL R14,SETVAR Define stem.FT LA R1,4(R1) R1 -> FM string data MVI 0(R8),2 Store filemode length MVC 1(2,R8),IFM Copy filemode BAL R14,SETVAR Define stem.FM LA R1,4(R1) R1 -> FORMAT string data MVI 0(R8),6 Set to BinHex MVC 1(6,R8),=C'BinHex' TM FLAGS,MACBIN MacBinary? BZ USEFMT No, keep format MVI 0(R8),9 Set to MacBinary MVC 1(9,R8),=C'MacBinary' USEFMT BAL R14,SETVAR Define stem.FORMAT LA R1,4(R1) R1 -> NAME string data MVC 0(1,R8),HDFNLEN Copy length of name MVC 1(63,R8),HDFN Copy maximum text L R2,FRASCADR Translate to EBCDIC TR 1(63,R8),0(R2) BAL R14,SETVAR Define stem.NAME LA R1,4(R1) R1 -> TYPE string data MVI 0(R8),4 Length = 4 MVC 1(4,R8),HDFTYP Copy type text TR 1(4,R8),0(R2) Translate to EBCDIC BAL R14,SETVAR Define stem.TYPE LA R1,4(R1) R1 -> CREATOR string data MVI 0(R8),4 Length = 4 MVC 1(4,R8),HDFCREAT Copy type text TR 1(4,R8),0(R2) Translate to EBCDIC BAL R14,SETVAR Define stem.CREATOR LA R1,4(R1) R1 -> FLAGS string data ICM R3,B'1100',HDFLAGS Get flags in msb of R3 LA R4,FLAGTEXT R4 -> list of names LA R5,16 R5 = bit count LA R6,1 R6 = buffer offset FLGLP2 EQU * Loop to set flag names SR R2,R2 Get next bit in R2 SLDL R2,1 LTR R2,R2 Is bit set? BZ FLGNXT2 No, skip name C R6,=F'1' First name? BE SKIPPL2 Yes, skip "+" IC R7,=C'+' Else append "+" STC R7,0(R6,R8) LA R6,1(R6) SKIPPL2 LA R7,0(R6,R8) R7 -> where to put text MVC 0(4,R7),0(R4) Copy flag name LA R6,4(R6) FLGNXT2 LA R4,4(R4) R4 -> next name BCT R5,FLGLP2 C R6,=F'1' Any flags? BNE HAVEFLG2 Yes, continue LA R7,0(R6,R8) Else append "none" MVC 0(4,R7),=C'none' LA R6,4(R6) HAVEFLG2 BCTR R6,0 R6 = line length STC R6,0(R8) Store for SETVAR BAL R14,SETVAR Define stem.FLAGS LA R1,4(R1) R1 -> DATASIZE string data LR R2,R1 Save R1 across NUMTOSTR ICM R0,B'1111',HDDATALN R0 = size of data fork LA R1,1(R8) R1 -> buffer for number BAL R14,NUMTOSTR Convert to string STC R0,0(R8) Store string length LR R1,R2 Restore R1 for SETVAR BAL R14,SETVAR Define stem.DATASIZE LA R1,4(R1) R1 -> RESCSIZE string data LR R2,R1 Save R1 across NUMTOSTR ICM R0,B'1111',HDRSCLN R0 = size of resource fork LA R1,1(R8) R1 -> buffer for number BAL R14,NUMTOSTR Convert to string STC R0,0(R8) Store string length LR R1,R2 Restore R1 for SETVAR BAL R14,SETVAR Define stem.RESCSIZE TM FLAGS,MACBIN MacBinary file? BZ VARRTN No, all info. defined LA R1,4(R1) R1 -> CRDATE string data LR R2,R1 Save R1 across SEC2DATE ICM R0,B'1111',HDCRDATE R0 = creation date LA R1,1(R8) R1 -> buffer for number BAL R14,SEC2DATE Convert to string STC R0,0(R8) Store string length LR R1,R2 Restore R1 for SETVAR BAL R14,SETVAR Define stem.CRDATE LA R1,4(R1) R1 -> MDDATE string data LR R2,R1 Save R1 across SEC2DATE ICM R0,B'1111',HDMDDATE R0 = last modified date LA R1,1(R8) R1 -> buffer for number BAL R14,SEC2DATE Convert to string STC R0,0(R8) Store string length LR R1,R2 Restore R1 for SETVAR BAL R14,SETVAR Define stem.MDDATE VARRTN LM R0,R15,VARSAVE Restore registers BR R14 Return to caller SPACE VARSAVE DS 8D Local save area EJECT * * SETVAR - Define REXX variable to a given value. The variable * to be defined will be stemname.suffix, where "stemname" * was specified in the "STEM" option, and R1 contains the * address of a pointer to the length and text of "suffix". * The length and text of the variable's value is found in * DATABUFF. * SETVAR DS 0H STM R0,R15,SETSAVE Save registers MVC NAMEBUFF(8),STEMNAME Copy stem name L R3,STEMSIZE R3 = length of name LA R2,NAMEBUFF(R3) R2 -> next available byte MVI 0(R2),C'.' Append period LA R2,1(R2) Increment pointer LA R3,1(R3) Increment size L R1,0(R1) R1 -> length, text for suffix SR R5,R5 R5 = length IC R5,0(R1) LA R4,1(R1) R4 -> text BCTR R5,0 Decrement length for EX EX R5,NAMEMVC LA R3,1(R3,R5) R3 = length of variable name LA R2,NAMEBUFF R2 -> value of name L R1,=A(DATABUFF) R1 -> length, text of value SR R5,R5 R5 = length of value IC R5,0(R1) LA R4,1(R1) R4 -> value for variable LA R6,MYSHBLK Address shared variable block USING SHVBLOCK,R6 XC SHVBLOCK(SHVBLEN),SHVBLOCK Initialize to zeros MVI SHVCODE,C'S' Store code to set a variable STM R2,R5,SHVNAMA Store name and value info. XC EXTPLIST(16),EXTPLIST Initialize extended plist DROP R6 Done with shared variable block LA R1,=CL8'EXECCOMM' R1 -> function name ST R1,EXTPLIST Store in extended plist ICM R1,B'1000',=X'02' Indicate subcommand call ST R6,EXTPLIST+12 Store A(shared variable block) LA R0,EXTPLIST R0 -> extended plist SVC 202 Invoke EXECCOMM to set variable DC AL4(1) Ignore errors LTR R15,R15 Check return code BZ SETRTN Ok if zero C R15,=F'-3' Check for environment error BE BADENV LR R2,R15 Save RC DMSERR NUM=632,LET=E, X TEXT='Error setting EXEC variable: RC=..... from ''EXECCX OMM'' function',SUB=(DEC,(R2)) MVI RTNCODE+3,200 Set RC = 200 B CMSRTN Return to CMS SPACE BADENV DMSERR NUM=631,LET=E, X TEXT='''STEM'' option is only available from an EXEC2 orX REXX exec' MVI RTNCODE+3,4 Set RC = 4 B CMSRTN Return to CMS SPACE SETRTN LM R0,R15,SETSAVE Restore register BR R14 Return to caller SPACE SETSAVE DS 8D Local save area NAMEBUFF DS 3D Variable name constructed here MYSHBLK DS 4D Shared variable block EXTPLIST DS 4F Extended plist for EXECCOMM NAMEMVC MVC 0(*-*,R2),0(R4) Append suffix after stem EJECT * * BINHEX Data Area: * SPACE NODEID DS 1D Local node id BROWNID DC CL8'BROWNVM' Brown node id INPLIST DS 0D Input file all-purpose plist INCMMD DS CL8 command name (ignored for BALR) IFN DS CL8 filename IFT DS CL8 filetype IFM DS CL2 filemode RDUN1 DS H unused RDADDR DS A statefst addr.; rdbuf buffer RDBUFLTH DS F size of rdbuf buffer RDFV DS C recfm (F or V) RDFLAG DS X plist flag RDUN2 DS H unused RDLGTH DS A no. of bytes read (filled-in) RDITEM DS A extended item number RDITEC DS A extended number of items RDWP DS A write pointer RDRP DS A read pointer SPACE OUTPLIST DS 0D Output file all-purpose plist OUTCMMD DS CL8 command name (ignored for BALR) OFN DS CL8 filename OFT DS CL8 filetype OFM DS CL2 filemode WRUN1 DS H unused WRADDR DS A statefst addr.; wrbuf buffer WRBUFLTH DS F size of wrbuf buffer WRFV DS C recfm (F or V) WRFLAG DS X plist flag WRUN2 DS H unused WRUN3 DS A unused WRITEM DS A extended item number WRITEC DS A extended number of items WRWP DS A write pointer WRRP DS A read pointer SPACE DS 0D TYPLIN Plist to type description TYPLIST DC CL8'TYPLIN' command name for SVC 202 DC AL1(1) obsolete terminal number DC AL3(DATABUFF+1) string address DC C'B' color (Black) DC AL1(0) flag byte TYPLEN DC AL2(*-*) string length SPACE DS 0D ATTN Plist to stack description STKLIST DC CL8'ATTN' command name for SVC 202 STKORDR DC CL4'FIFO' LIFO or FIFO STKLEN DC AL1(*-*) string length DC AL3(DATABUFF+1) string length SPACE STEMNAME DS 1D Stem variable names HDREC DS 16D File header info. (128 bytes) ORG HDREC Define header fields HDVER DS 1X version byte HDFNLEN DS 1X length of filename HDFN DS 63C filename * start of Finder Info record HDFTYP DS 4C file type HDFCREAT DS 4C file creator HDFLAGS DS 1X finder flags HDFLAG2 DS 1X second flag byte HDVPOS DS 2X vertical position HDHPOS DS 2X horizontal position HDID DS 2X window or folder ID * end of Finder Info record HDPFLAG DS 1X "protected" flag HDZERO2 DS 1X zero HDDATALN DS 4X data fork length HDRSCLN DS 4X resource fork length HDCRDATE DS 4X creation date HDMDDATE DS 4X last modified date HDZERO3 DS 29X zero fill ORG BINLEN DS 1F Length of data in BINBUFF BINXTADR DS 1A Addr. for processing left over bits BINOFF DS 1F Offset into BINBUFF for GETSTR RDOFF DS 1F Offset into READBUFF for GTBINLIN EOFPOS DS 1F Position of EOFCHAR in current line CHRTOTAL DS 1F Total char. read by GETLINE CPS DS 1F Xfer rate chars./sec. or zero EXPLEN DS 1F No. of bytes in EXPBUFF WRLEN DS 1F HQX output line length STEMSIZE DS 1F Length of STEMNAME FRASCADR DS A A(ASCII to EBCDIC table) TOASCADR DS A A(EBCDIC to ASCII table) OPRTAB DS 0F Operand processing table DC CL8'?',AL4(QUESOPR) DC CL8'CHECK',AL4(CHKOPR) DC CL8'CONVERT',AL4(CVTOPR) DC CL8'DESCRIBE',AL4(DESCOPR) DC 8X'FF',AL4(-1) OPTTAB DS 0F Option processing table DC CL8'FIFO',AL4(STKOPT) DC CL8'LIFO',AL4(LIFOOPT) DC CL8'RATE',AL4(RATEOPT) DC CL8'STACK',AL4(STKOPT) DC CL8'STEM',AL4(STEMOPT) DC CL8'TO',AL4(TOOPT) DC 8X'FF',AL4(-1) CRCVAL DS 1H Calculated CRC CMPLBYTE DS 1X Last byte for compression CMPCNT DS 1X Compression count CMPCHAR DS 1C Character for compression BINLAST DS 1X Last character in BINBUFF BINEXTRA DS 1X Left over binary data OPRCODE DS 1C Code for first operand EOFCHAR DS 1C Invalid char. GETLINE stopped at CMPMODE DS 1X Current state for HQX compression HCMPCHAR DS 1C Last character for HQX compression CMPCOUNT DS 1X Character count for HQX comp. FLAGS DS 1X Flag byte MACBIN EQU X'01' Input file is MacBinary RDOPEN EQU X'02' Input file is open WROPEN EQU X'04' Output file is open HQXCOLON EQU X'08' Found first colon for HQX file HQXEOF EQU X'10' Found eof colon for HQX file X90DATA EQU X'20' Use data byte from last X'90' STKDESC EQU X'40' Stack description output STKLIFO EQU X'80' Stack output LIFO FLAGS2 DS 1X Second flag byte EXECVAR EQU X'01' Return header info in vars. NOCOMMA EQU X'02' Suppress commas for NUMTOSTR FLAGTEXT DC C'LockInvsBndlSystBozoBusyChngInit' DC C'CachShrdSwitNoSwRsv3Rsv2OwnADesk' LTORG DROP R11,R12,R13 EJECT TOASCBRN DS 0D BROWN'S CP EBCDIC TO ASCII TRANSLATE TABLE DC X'000102037F097F7F7F7F7F0B0C0D0E0F' *....".""""".....* DC X'101112137F0A087F18197F7F1C1D1E1F' *....".."..""....* DC X'7F7F1C7F7F0A171B7F7F7F7F7F050607' *"".""..."""""...* DC X'7F7F167F7F1E7F047F7F7F1314157F1A' *"".""."."""...".* DC X'207F7F7F7F7F7F7F7F7F5B2E3C282B5E' *."""""""""$....;* DC X'267F7F7F7F7F7F7F7F7F21242A293B7E' *.""""""""".....=* DC X'2D2F7F7F7F7F7F7F7F7F7C2C255F3E3F' *..""""""""@..~..* DC X'7F7F7F7F7F7F7F7F607F3A2340273D22' *""""""""-".. ...* DC X'7F6162636465666768697F7B7F7F7F7F' *"/........"#""""* DC X'7F6A6B6C6D6E6F7071727F7D7F7F7F7F' *".,%_>?..."'""""* DC X'7F7F737475767778797A7F7F7F5B7F7F' *"".......:"""$""* DC X'7F7F7F7F7F7F7F7F7F7F7F7F7F5D7F7F' *""""""""""""")""* DC X'7F4142434445464748497F7F7F7F7F7F' *".........""""""* DC X'7F4A4B4C4D4E4F5051527F7F7F7F7F7F' *"..<(+|&..""""""* DC X'5C7F535455565758595A7F7F7F7F7F7F' **".......!""""""* DC X'303132333435363738397F7F7F7F7F7F' *..........""""""* SPACE FRASCBRN DS 0D BROWN'S CP ASCII TO EBCDIC TRANSLATE TABLE DC X'00010203372D2E2F1605250B0C0D0E0F' DC X'FF11123B3C3D322618193F271C1D1E1F' DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD4F6D' DC X'78818283848586878889919293949596' DC X'979899A2A3A4A5A6A7A8A98B6A9B5F07' DC X'00010203372D2E2F1605250B0C0D0E0F' DC X'FF11123B3C3D322618193F271C1D1E1F' DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD4F6D' DC X'78818283848586878889919293949596' DC X'979899A2A3A4A5A6A7A8A98B6A9B5F07' EJECT TOASCSTD DS 0D STANDARD CP EBCDIC TO ASCII TABLE DC X'000102037F097F7F7F7F7F0B0C0D0E0F' *....".""""".....* DC X'101112137F0A080018197F7F1C1D1E1F' *....".....""....* DC X'7F7F7F7F7F0A171B7F7F7F7F7F050607' *"""""..."""""...* DC X'7F7F167F7F7F7F047F7F7F7F14157F1A' *""."""".""""..".* DC X'207F7F7F7F7F7F7F7F7F7F2E3C282B7C' *.""""""""""....@* DC X'267F7F7F7F7F7F7F7F7F21242A293B5E' *.""""""""".....;* DC X'2D2F7F7F7F7F7F7F7F7F7C2C255F3E3F' *..""""""""@..~..* DC X'7F7F7F7F7F7F7F7F7F603A2340273D22' *"""""""""-.....* DC X'7F6162636465666768697F7F7F7F7F7F' *"/........""""""* DC X'7F6A6B6C6D6E6F7071727F7F7F7F7F7F' *".,%_>?...""""""* DC X'7F7E737475767778797A7F7F7F5B7F7F' *"=.......:"""$""* DC X'7F7F7F7F7F7F7F7F7F7F7F7F7F5D7F7F' *""""""""""""")""* DC X'7B4142434445464748497F7F7F7F7F7F' *#.........""""""* DC X'7D4A4B4C4D4E4F5051527F7F7F7F7F7F' *'.<(+|&..""""""* DC X'5C7F535455565758595A7F7F7F7F7F7F' **".......!""""""* DC X'303132333435363738397F7F7F7F7F7F' *..........""""""* SPACE FRASCSTD DS 0D STANDARD CP ASCII TO EBCDIC TABLE DC X'00010203372D2E2F1605250B0C0D0E0F' DC X'101112133C3D322618193F271C1D1E1F' DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' DC X'79818283848586878889919293949596' DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' DC X'00010203372D2E2F1605250B0C0D0E0F' DC X'101112133C3D322618193F271C1D1E1F' DC X'405A7F7B5B6C507D4D5D5C4E6B604B61' DC X'F0F1F2F3F4F5F6F7F8F97A5E4C7E6E6F' DC X'7CC1C2C3C4C5C6C7C8C9D1D2D3D4D5D6' DC X'D7D8D9E2E3E4E5E6E7E8E9ADE0BD5F6D' DC X'79818283848586878889919293949596' DC X'979899A2A3A4A5A6A7A8A9C04FD0A107' EJECT VALIDTAB DS 256X TRT table for valid characters * (Filled-in at initialization) CMPTAB DC 256X'00' TRT table for X'90' ORG CMPTAB+X'90' DC X'FF' ORG SPACE ASCTOBIN DS 0D DC 128X'FF' ORG ASCTOBIN+X'21' DC X'00010203040506070809' ! " # $ % & ' ( ) * DC X'0A0B0C' + , - ORG ASCTOBIN+X'30' DC X'0D0E0F10111213' 0 1 2 3 4 5 6 ORG ASCTOBIN+X'38' DC X'1415' 8 9 ORG ASCTOBIN+X'40' DC X'161718191A1B1C1D1E1F' @ A B C D E F G H I DC X'2021222324' J K L M N ORG ASCTOBIN+X'50' DC X'25262728292A2B' P Q R S T U V ORG ASCTOBIN+X'58' DC X'2C2D2E2F' X Y Z [ ORG ASCTOBIN+X'60' DC X'30313233343536' i a b c d e f ORG ASCTOBIN+X'68' DC X'3738393A3B3C' h i j k l m ORG ASCTOBIN+X'70' DC X'3D3E3F' p q r ORG * ! " # $ % & ' ( ) * + , - 0 1 2 3 4 5 6 8 9 @ BINTOASC DC X'2122232425262728292A2B2C2D30313233343536383940' * A B C D E F G H I J K L M N P Q R S T U V X Y DC X'4142434445464748494A4B4C4D4E505152535455565859' * Z [ i a b c d e f h i j k l m p q r DC X'5A5B6061626364656668696A6B6C6D707172' HQXMSG DC C'(This file must be converted with BinHex 4.0)' HQXMSGL EQU *-HQXMSG SPACE VARTAB DS 0A Address table for REXX var. names DC A(VAR1) DC A(VAR2) DC A(VAR3) DC A(VAR4) DC A(VAR5) DC A(VAR6) DC A(VAR7) DC A(VAR8) DC A(VAR9) DC A(VAR10) DC A(VAR11) DC A(VAR12) AVAR13 DC A(VAR13) AVAR14 DC A(VAR14) VAR1 DC AL1(VAR1L),C'FN' CMS filename VAR1L EQU *-VAR1-1 VAR2 DC AL1(VAR2L),C'FT' CMS filetype VAR2L EQU *-VAR2-1 VAR3 DC AL1(VAR3L),C'FM' CMS filemode VAR3L EQU *-VAR3-1 VAR4 DC AL1(VAR4L),C'FORMAT' MacBinary or BinHex VAR4L EQU *-VAR4-1 VAR5 DC AL1(VAR5L),C'NAME' Mac filename VAR5L EQU *-VAR5-1 VAR6 DC AL1(VAR6L),C'TYPE' Mac type VAR6L EQU *-VAR6-1 VAR7 DC AL1(VAR7L),C'CREATOR' Mac creator VAR7L EQU *-VAR7-1 VAR8 DC AL1(VAR8L),C'FLAGS' Mac flags VAR8L EQU *-VAR8-1 VAR9 DC AL1(VAR9L),C'DATASIZE' Mac data fork size VAR9L EQU *-VAR9-1 VAR10 DC AL1(VAR10L),C'RESCSIZE' Mac resource fork size VAR10L EQU *-VAR10-1 VAR11 DC AL1(VAR11L),C'CRDATE' Mac creation date VAR11L EQU *-VAR11-1 VAR12 DC AL1(VAR12L),C'MDDATE' Mac last modified date VAR12L EQU *-VAR12-1 VAR13 DC AL1(VAR13L),C'CHARCNT' Total character count VAR13L EQU *-VAR13-1 VAR14 DC AL1(VAR14L),C'TIMEEST' Dowload time estimate VAR14L EQU *-VAR14-1 SPACE EXPBUFF DS 6D 48-byte HQX expansion buffer WRITBUFF DS 8D 64-byte disk output buffer DATABUFF DS 16D 128-byte work buffer BINBUFF DS 25D Binary from READBUFF READBUFF DS 32D 256-byte disk input buffer ADT FSTB FVS NUCON SHVBLOCK END ---------- end of BINHEX ASSEMBLE ----------------------------------- ---------- start of BINHEX HELPCMS: 224 lines follow ---------------- ..fo off ..cs 1 on BINHEX Use the BINHEX command to work with Macintosh files containing binary data which are stored in CMS. BINHEX may be used with HQX files, such as those created by BinHex 4.0 on the Macintosh, and also with BIN files, such as those created by BinHex 5.0. BINHEX checks files in these formats, describes the contents of the files, and converts between the two formats. ..cs 1 off ..cs 2 on The format of the BINHEX command is: ?~~~~~~~~~~]~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\ k k k k BINHEX k ? | Check | Describe | COnvert fn <ft <fm >> [(options...[)]] k k k k k k Options: k k k ? \ ? \ ? \ k k k kTo fm k kStack k kFifo k k k k kRate cps k kLifo k kSTEm stm k k k k > ; > ; > ; k k k k >~~~~~~~~~~[~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~; ..cs 2 off ..cs 3 on OPERANDS ? causes BINHEX to type a brief description of the command format, including all the valid operands and options. When "?" is specified, the remainder of the command line is ignored. Check cause BINHEX to check the input file for errors, such as missing or corrupted data. BINHEX will either report there are no errors, or respond with an error message describing the problem. BINHEX also checks the input file when the Describe or COnvert operand is specified. Describe causes BINHEX to display information about the input file, including the full Macintosh filename, the type, creator, flags values, and the sizes of the data and resource forks. See the "Responses" section below for examples of the information which is displayed. COnvert causes BINHEX to convert the input file from BinHex to MacBinary format or vice-versa. The resulting file has the same filename as the input file, and a filetype of either BIN (for MacBinary format) or HQX (for BinHex format). The file is written to the same disk as the input file, unless the "To" option has been specified. fn specifies the filename of the input file. ft specifies the filetype of the input file. When "ft" is omitted or specified as "*", all filetypes will be searched to find a match for "fn". fm specifies the filemode of the input file. When "fm" is omitted or specified as "*", all accessed disks will be searched for a file matching "fn" and "ft". OPTIONS To fm specifies the disk to which the output file will be written when the "COnvert" operand is specified. When "To" is omitted, the output file is written to the same disk as the input file. Rate cps specifies a file transfer rate in characters per second. When a rate is specified, the information displayed by the "Describe" function will include an estimate of the time required to download the file. Stack cause the output from the "Describe" function to be stacked in FIFO order. "Fifo" is a synonym for "Stack". Lifo causes the output from the "Describe" function to be stacked in LIFO order. Fifo cause the output from the "Describe" function to be stacked in FIFO order. "Stack" is a synonym for "Fifo". STEm stm causes the output from the "Describe" function to be stored directly into REXX or EXEC2 variables. "stm" is the name of the stem for these variables, i.e. the characters preceding a period in their names. Only the first eight characters of "stm" are significant. The following variables are defined: stm.FN CMS filename stm.FT CMS filetype stm.FM CMS filemode stm.FORMAT BinHex or MacBinary stm.NAME Mac filename stm.TYPE Mac type stm.CREATOR Mac creator stm.FLAGS Mac flags stm.DATASIZE Mac data fork size stm.RESCSIZE Mac resource fork size stm.CRDATE Mac creation date stm.MDDATE Mac last modified date stm.CHARCNT Total character count stm.TIMEEST Download time estimate The creation and last modified dates are not defined for BinHex format files, which do not include them. The time estimate is defined only when the Rate option has been specified. USING THE BINHEX COMMAND The BINHEX command allows Macintosh users to obtain information about files stored in CMS which would ordinarily not be available until the files had been downloaded to a Macintosh. The Check function verifies that a file will be accepted by BinHex on the Macintosh, and the Describe function provides detailed information about a file. With this information, a Macintosh user can often avoid spending time downloading unwanted files or files which contain errors. The COnvert function provides conversion between the two file formats BINHEX accepts: BinHex format and MacBinary format. Conversion is useful because each of these formats offers advantages for storing Macintosh programs. BinHex format is used by BinHex 4.0 on the Macintosh. It consists of a header, the data fork, and the resource fork of a Macintosh file, compressed and converted to printable characters. Converting a file from binary to printable characters increases its size (in spite of the inclusion of file compression). However, since they contain only printable characters, BinHex files can be included in electronic mail, and can be uploaded and downloaded in nearly any environment. In CMS, BinHex files usually are given filetypes containing "HQX", and may have fixed or variable-length records. The files usually begin with the line (This file must be converted with BinHex 4.0) MacBinary format is used by BinHex 5.0 and MacTerminal on the Macintosh. It is similar to BinHex format, but retains the file contents in binary form instead of converting to printable characters. It also includes the dates the Macintosh file was created and last modified, and some extra flag bits. MacBinary is the most compact format for storing a Macintosh file. However, because MacBinary files retain binary data, they can be uploaded and downloaded only by programs which use an 8-bit data path. Usually, such a path is not available for VM/CMS systems. Programs such as Kermit can simulate an 8-bit path using printable characters, but only at the expense of a much longer transfer time. MacBinary files in CMS usually are given filetypes containing "BIN". They consist of fixed-length 128-byte records. USAGE NOTES 1) Although the filetype of the input file will usually indicate which format it is in, BINHEX determines the file's format by examining its characteristics. If the file has fixed-length 128-byte records, BINHEX assumes MacBinary format. Otherwise, BINHEX assumes BinHex format. 2) The data in a BinHex format file begins with a line containing a colon in column one, and ends with a line having a colon as the last character. CMS BINHEX skips any other lines in the file. However, BinHex on the Macintosh only skips the comment line "(This file must be converted with BinHex 4.0)". Thus, even when the Check function reports no errors, it may still be necessary to delete extraneous lines from the BinHex file before BinHex on the Macintosh will accept the file. 3) BinHex format files do not contain all the information included in MacBinary files. In particular, the creation and last modified dates, and some flag bits are not stored. As a result, this information is lost when the COnvert function is used to convert from MacBinary to BinHex format. 4) BINHEX cannot detect if the input file is not in either MacBinary or BinHex format. In this case, BINHEX will usually assume the file is in BinHex format, and give an "unexpected end-of-file" message when it fails to find the first line of BinHex data. 5) For a BinHex file, the maximum line length BINHEX can process is 256. RESPONSES 'fn ft fm': No errors detected. This is the normal response from the Check function. This response is omitted when BINHEX is called from a CMS command, or from an exec file with "address COMMAND" in effect. File: 'STARS16 HQX T1' Format: BinHex Filename: 'Stars 1.6' Type: 'DFIL' Creator: 'DMOV' Flags: none Data fork size: 0; Resource fork size: 6,054 Character count: 10,140. This is the response from the Describe function for a BinHex file when the Rate option is not used. This is the shortest possible description. File: 'TERM412 BIN M1' Format: MacBinary Filename: 'Term 4.12' Type: 'APPL' Creator: 'TRMA' Flags: Bndl+Init Data fork size: 0; Resource fork size: 52,947 Created: Thu, May 28, 1987 2:01:25 AM Last Modified: Thu, May 28, 1987 2:02:04 AM Character count: 53,120 (4 minutes, 55 seconds at 180 cps). This is the response from the Describe function for a MacBinary file when the Rate option is used. This is the longest possible description. OTHER MESSAGES AND RETURN CODES DMSBIN631E 'STEM' option is only available from an EXEC2 or REXX exec. RC=4 DMSBIN001E Error in command after 'token'. RC=24 DMSBIN002I Issue BINHEX ? or HELP CMS BINHEX for more information. DMSBIN003E Invalid option 'xxxxxxxx'. RC=24 DMSBIN010E Invalid rate 'xxxxxxxx'. RC=24 DMSBIN048E Invalid mode 'xxxxxxxx'. RC=24 DMSBIN637E Missing value for the 'STEM' option. RC=24 DMSBIN002E File 'fn ft fm' not found. RC=28 DMSBIN024E File 'fn ft fm' already exists. RC=28 DMSBIN044E Record length exceeds allowable maximum. RC=32 DMSBIN005E Invalid character 'x' in 'fn ft fm' at line mmmmmm position nnn. RC=36 DMSBIN006E Unexpected end-of-file reading 'fn ft fm'. RC=36 DMSBIN037E Disk 'mode' is read-only. RC=36 DMSBIN069E Disk 'mode' not accessed. RC=36 DMSBIN007E 'fn ft fm': CRC error for BinHex header. RC=44 DMSBIN008E 'fn ft fm': CRC error for BinHex data fork. RC=44 DMSBIN009E 'fn ft fm': CRC error for BinHex resource fork. RC=44 DMSBIN104S Error 'nn' reading file 'fn ft fm' from disk. RC=1nn DMSBIN105S Error 'nn' writing file 'fn ft fm' on disk. RC=1nn DMSBIN632E Error setting EXEC variable: RC=nnnnn from 'EXECCOMM'. RC=200 ..cs 3 off ---------- end of BINHEX HELPCMS ------------------------------------ ---------- start of XMDMGEN C: 62 lines follow ---------------------- /* This program generates the XMODEM CRC table in XMDMTAB ASSEMBLE. */ /* Peter DiCamillo, June, 1987 */ #include "stdio.h" main() , FILE *io; unsigned int array[256]; register char x1, x2, x3, x4, x5, x6, x7, x8; int count; int i, j, k; char ioline[132], iobuff[80]; count = 0; for (x8=0; x8 < 2; x8++) for (x7=0; x7 < 2; x7++) for (x6=0; x6 < 2; x6++) for (x5=0; x5 < 2; x5++) for (x4=0; x4 < 2; x4++) for (x3=0; x3 < 2; x3++) for (x2=0; x2 < 2; x2++) for (x1=0; x1 < 2; x1++) , array[count] = 0; if (x8 ~ x4) array[count] += 0x8000; if (x7 ~ x3) array[count] += 0x4000; if (x6 ~ x2) array[count] += 0x2000; if (x8 ~ x5 ~ x1) array[count] += 0x1000; if (x7) array[count] += 0x0800; if (x6) array[count] += 0x0400; if (x5) array[count] += 0x0200; if (x8 ~ x4) array[count] += 0x0100; if (x8 ~ x7 ~ x3) array[count] += 0x0080; if (x7 ~ x6 ~ x2) array[count] += 0x0040; if (x6 ~ x5 ~ x1) array[count] += 0x0020; if (x5) array[count] += 0x0010; if (x8 ~ x4) array[count] += 0x0008; if (x7 ~ x3) array[count] += 0x0004; if (x6 ~ x2) array[count] += 0x0002; if (x5 ~ x1) array[count] += 0x0001; count++; - /* Output assemble file with the table */ io = fopen("xmdmtab assemble a (lrecl 80 recfm f","w"); j = 6; /* number of contants on current line */ strcpy(ioline,"XMDMTAB CSECT"); for (i = 0; i < 256; i++) , if (j == 6) , fprintf(io, "%s\n", ioline); j = 0; strcpy(ioline," DC "); - if (j != 0) strcat(ioline,","); sprintf(iobuff,"X'%04x'",array[i]); strcat(ioline,iobuff); j++; - if (j != 0) fprintf(io, "%s\n", ioline); fclose(io); - ---------- end of XMDMGEN C ----------------------------------------- ---------- start of XMDMTAB ASSEMBLE: 46 lines follow --------------- * Table for calculating XMODEM CRC; generated by XMDMGEN C XMDMTAB CSECT TABLE FOR GENERATING XMODEM CRC DC X'0000',X'1021',X'2042',X'3063',X'4084',X'50A5' DC X'60C6',X'70E7',X'8108',X'9129',X'A14A',X'B16B' DC X'C18C',X'D1AD',X'E1CE',X'F1EF',X'1231',X'0210' DC X'3273',X'2252',X'52B5',X'4294',X'72F7',X'62D6' DC X'9339',X'8318',X'B37B',X'A35A',X'D3BD',X'C39C' DC X'F3FF',X'E3DE',X'2462',X'3443',X'0420',X'1401' DC X'64E6',X'74C7',X'44A4',X'5485',X'A56A',X'B54B' DC X'8528',X'9509',X'E5EE',X'F5CF',X'C5AC',X'D58D' DC X'3653',X'2672',X'1611',X'0630',X'76D7',X'66F6' DC X'5695',X'46B4',X'B75B',X'A77A',X'9719',X'8738' DC X'F7DF',X'E7FE',X'D79D',X'C7BC',X'48C4',X'58E5' DC X'6886',X'78A7',X'0840',X'1861',X'2802',X'3823' DC X'C9CC',X'D9ED',X'E98E',X'F9AF',X'8948',X'9969' DC X'A90A',X'B92B',X'5AF5',X'4AD4',X'7AB7',X'6A96' DC X'1A71',X'0A50',X'3A33',X'2A12',X'DBFD',X'CBDC' DC X'FBBF',X'EB9E',X'9B79',X'8B58',X'BB3B',X'AB1A' DC X'6CA6',X'7C87',X'4CE4',X'5CC5',X'2C22',X'3C03' DC X'0C60',X'1C41',X'EDAE',X'FD8F',X'CDEC',X'DDCD' DC X'AD2A',X'BD0B',X'8D68',X'9D49',X'7E97',X'6EB6' DC X'5ED5',X'4EF4',X'3E13',X'2E32',X'1E51',X'0E70' DC X'FF9F',X'EFBE',X'DFDD',X'CFFC',X'BF1B',X'AF3A' DC X'9F59',X'8F78',X'9188',X'81A9',X'B1CA',X'A1EB' DC X'D10C',X'C12D',X'F14E',X'E16F',X'1080',X'00A1' DC X'30C2',X'20E3',X'5004',X'4025',X'7046',X'6067' DC X'83B9',X'9398',X'A3FB',X'B3DA',X'C33D',X'D31C' DC X'E37F',X'F35E',X'02B1',X'1290',X'22F3',X'32D2' DC X'4235',X'5214',X'6277',X'7256',X'B5EA',X'A5CB' DC X'95A8',X'8589',X'F56E',X'E54F',X'D52C',X'C50D' DC X'34E2',X'24C3',X'14A0',X'0481',X'7466',X'6447' DC X'5424',X'4405',X'A7DB',X'B7FA',X'8799',X'97B8' DC X'E75F',X'F77E',X'C71D',X'D73C',X'26D3',X'36F2' DC X'0691',X'16B0',X'6657',X'7676',X'4615',X'5634' DC X'D94C',X'C96D',X'F90E',X'E92F',X'99C8',X'89E9' DC X'B98A',X'A9AB',X'5844',X'4865',X'7806',X'6827' DC X'18C0',X'08E1',X'3882',X'28A3',X'CB7D',X'DB5C' DC X'EB3F',X'FB1E',X'8BF9',X'9BD8',X'ABBB',X'BB9A' DC X'4A75',X'5A54',X'6A37',X'7A16',X'0AF1',X'1AD0' DC X'2AB3',X'3A92',X'FD2E',X'ED0F',X'DD6C',X'CD4D' DC X'BDAA',X'AD8B',X'9DE8',X'8DC9',X'7C26',X'6C07' DC X'5C64',X'4C45',X'3CA2',X'2C83',X'1CE0',X'0CC1' DC X'EF1F',X'FF3E',X'CF5D',X'DF7C',X'AF9B',X'BFBA' DC X'8FD9',X'9FF8',X'6E17',X'7E36',X'4E55',X'5E74' DC X'2E93',X'3EB2',X'0ED1',X'1EF0' END ---------- end of XMDMTAB ASSEMBLE ----------------------------------